c     DRDCPLTK
c>> 2001-06-17 DRDCPLTK Krogh Changed T computation.
c>> 1996-05-30 DRDCPLTK Krogh Added external statement.
c>> 1994-10-19 DRDCPLTK Krogh  Changes to use M77CON
c>> 1994-09-01 DRDCPLTK WVS Moved formats to top for C conversion
c>> 1994-08-09 DRDCPLTK WVS set up for CHGTYP
c>> 1992-04-29 DRDCPLTK CAO Replaced '1' in format.
c>> 1991-11-19 DRDCPLTK CLL
c>> 1987-12-09 DRDCPLTK Lawson  Initial Code.
c--D replaces "?": DR?CPLTK, ?CPLTK, ?CPLTE
c
c     DEMONSTRATION DRIVER FOR ELLIPTIC INTEGRALS.
c
c     EVALUATE THE LEGENDRE'S RELATION:
c     Z = PI/2 - (K*E1 + K1*E - K*K1) = 0
c
      external D1MACH, DCPLTK, DCPLTE
      double precision D1MACH, DCPLTK, DCPLTE
      double precision EM(6),K,K1,E,E1, ONE
      double precision PI2, T, TPRIME, Z, ZERO
      integer I
      data PI2 / 1.5707963267948966192313217D0 /
      data EM / 0.001D0, .2D0, .4D0, .6D0, .8D0, .999D0 /
      data ZERO,ONE / 0.D0, 1.D0 /
c
  200 format(5X,A2,9X,A10,7X,A10,8X,A1/' ')
  300 format(2X,F6.3,2X,F15.8,2X,F15.8,3X,G10.2)
  400 format(3X,A1,6X,F15.8,2X,F15.8,3X,G10.2)
  500 format(2X,F6.3,9X,A8,2X,F15.8,3X,G10.2)
  600 format(/'  TPRIME = Machine epsilon =',E10.2)
  700 format('  T = 1. - TPRIME')
c
      TPRIME = D1MACH(4)
      T = ONE - TPRIME
c
      print 200,'EM','DCPLTK(EM)','DCPLTE(EM)','Z'
      print 300,ZERO,DCPLTK(ZERO),DCPLTE(ZERO)
c
      do 800 I = 1, 6
        K  = DCPLTK(EM(I))
        K1 = DCPLTK(1-EM(I))
        E  = DCPLTE(EM(I))
        E1 = DCPLTE(1-EM(I))
        Z  = PI2 - (K*E1 + K1*E - K*K1)
        print 300, EM(I), K, E, Z
  800 continue
      K  = DCPLTK( T )
      K1 = DCPLTK( TPRIME )
      E  = DCPLTE( T )
      E1 = DCPLTE( TPRIME )
      Z  = PI2 - (K*E1 + K1*E - K*K1)
      print 400, 'T', K, E, Z
      print 500, ONE, 'INFINITY', DCPLTE(ONE)
      print 600, TPRIME
      print 700
c
      end


      program Celsius to fahrenheit
      implicit none
            real :: C, F
            PRINT *, 'Enter temperature in Celsius'
            READ (*,*) C
            F=C*1.8+32
            PRINT *, C, "'C = ", F,"'F"
            PAUSE
      end program


      FUNCTION splintx(x)
      USE vparams
      USE vsvd0
      USE csplinx
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      REAL(rprec) x
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      REAL(rprec), PARAMETER :: c1o6 = 1._dp/6._dp
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: klo, khi, k
      REAL(rprec) :: h, a, b, h2, a2, b2, y26lo, y26hi, qmidx0,
     1   splintx
C-----------------------------------------------

      CALL setspline (rmidx, wmidx, qmidx, hmidx, ymidx, y2midx,
     1    tenmidx, tenmidx(1), nptsx, natur)

      klo = 1
      khi = nptsx

    1 CONTINUE
      IF (khi - klo .gt. 1) THEN
         k = (khi + klo)/2
         IF (rmidx(k) .gt. x) THEN
            khi = k
         ELSE
            klo = k
         ENDIF
         GOTO 1
      ENDIF

      h = rmidx(khi) - rmidx(klo)
      IF( h.eq.zero )then
        splintx = zero
        RETURN
      END IF
      a = rmidx(khi) - x
      b = x - rmidx(klo)
      h2 = h*h
      a2 = a*a
      b2 = b*b
      y26lo = c1o6*y2midx(klo)
      y26hi = c1o6*y2midx(khi)
      qmidx0 = (a*(ymidx(klo)+(a2-h2)*y26lo)+b*(ymidx(khi)+
     1   (b2-h2)*y26hi))/h
      splintx = qmidx0

      END FUNCTION splintx


subroutine addshotnoise(xout,yout,opixels,seed)
use precision
implicit none
!import vars
integer :: xout,yout,seed
real(double), dimension(:,:) :: opixels
!local vars
integer :: i,j
real(double) :: pmax,sat,gasdev,readnoise

!scale largest pixel to 75000 e-
sat=75000.0d0 !e-
!readnoise
readnoise=20.0d0 !e-

!find largest pixel value
pmax=maxval(opixels(1:xout,1:yout))
!scale (undone below)
opixels=opixels*sat/pmax

!add shot-noise (Guassian)
do i=1,xout
   do j=1,yout
      opixels(i,j)=opixels(i,j)+sqrt(abs(opixels(i,j)))*gasdev(seed)
   enddo
enddo

!add read noise
do i=1,xout
   do j=1,yout
      opixels(i,j)=opixels(i,j)+readnoise*gasdev(seed)
   enddo
enddo

!undo scaling
opixels=opixels/sat*pmax

end subroutine addshotnoise


!======================================================================!
  SUBROUTINE Factor(i, number, factrs)
!----------------------------------------------------------------------!
!   Splits the number into it's primal factors. ( 30 = 5 x 3 x 2 )     !
!----------------------------------------------------------------------!
  IMPLICIT NONE
!-----------------------------[Parameters]-----------------------------!
  INTEGER :: number, factrs(128)
!-------------------------------[Locals]-------------------------------!
  INTEGER :: i, j, primes(15)
!--------------------------------[CVS]---------------------------------!
!  $Id: Factor.f90,v 1.6 2002/10/30 16:29:18 niceno Exp $
!  $Source: /home/muhamed/.CVSROOT/T-Rex/Divide/Factor.f90,v $
!======================================================================!
  DATA primes /47,43,41,37,31,29,23,19,17,13,11, 7, 5, 3, 2/
!----------------------------------------------------------------------!
!   For example if factor is called with number = 30 it will split it  !
!   into 5,3 and 2, and make the following output:                     !
!   i=3, factrs(1)=5, factrs(2)=3, factrs(3)=2                         !
!   See also: Divide                                                   !
!----------------------------------------------------------------------!

  i=0
  do j=1,15

1   if( mod(number,primes(j)) == 0 ) then
      number = number/primes(j)
      i = i + 1
      factrs(i) = primes(j)
      goto 1
    endif

  end do

  END SUBROUTINE Factor


      SUBROUTINE WINDOW(JTYPE,BUF,N,BETA)
C
C     CALCULATES AND STORES A N POINT WINDOW FUNCTION IN BUF.
C     THE WHOLE WINDOW (BOTH HALVES) ARE COMPUTED AND STORED UNLESS JTYPE<0.
C    N IS THE TOTAL WINDOW LENGTH.
C
C     ARGUMENTS:
C        JTYPE  - INTEGER DESIGNATOR OF THE TYPE OF WINDOW TO CALCULATE.
C               <0,  ONLY THE LEFT HALF OF THE WINDOW IS RETURNED( BASED ON WINDOW OF 2*N)
C               >0, THE WHOLE WINDOW IS RETURN (BASED ON WINDOW OF N)
C               =1,  HAMMING
C               =2,  HANNING
C               =3,  GAUSSIAN
C               =4,  BARTLETT (TRIANGULAR)
C               =5,  RECTANGULAR (BOX CAR)
C               =6,  BLACKMAN
C               =7,  EXACT BLACKMAN
C               =8,  BLACKMAN HARRIS
C
C        BUF    - ARRAY TO STORE THE WINDOW MULTIPLIERS.  MUST BE N LONG.
C        N      - NUMBER OF POINTS OF THE WINDOW
C        BETA   - BETA THE VARIABLE BETA FOR THE GAUSSIAN WINDOW
C
C  WRITTEN AND COPYRIGHTED BY:
C  PAUL HENKART, SCRIPPS INSTITUTION OF OCEANOGRAPHY, NOVEMBER 1978
C  ALL RIGHTS ARE RESERVED BY THE AUTHOR.  PERMISSION TO COPY OR REPRODUCE THIS
C  SUBROUTINE, BY COMPUTER OR OTHER MEANS, MAY BE OBTAINED ONLY FROM THE AUTHOR.
      DIMENSION BUF(1)
      DATA E/2.71828/
      DATA PI2/6.2831853/
      M=N
      K=N
      IF(JTYPE.LT.0) K=N*2
C      K=K-1
C      I=K/2
C      IF(M/2*2.EQ.M) GO TO 10
C      I=I-1
C      IF(JTYPE.LT.0) I=I+1
      IF(JTYPE.LT.0) K=K-1
      I=-N/2
      SGN=1.
      IF(JTYPE.GT.0) GO TO 10
      I=0
      SGN=-1.
   10 CONTINUE
      I=I-1
      ITYPE=IABS(JTYPE)
      J=1
      IF(ITYPE.LT.1.OR.ITYPE.GT.8) RETURN
      GO TO (100,200,300,400,500,600,700,800), ITYPE
C****
C****      HAMMING FUNCTION
C****
  100 CONTINUE
  110 I=I+1
      BUF(J)=.54+.46*SGN*COS(FLOAT(I)*PI2/FLOAT(K))
      J=J+1
      IF(J.LE.M) GO TO 110
      RETURN
C****
C****        HANNING
C****
  200 CONTINUE
  210 I=I+1
      BUF(J)=.5+.5*SGN*COS(FLOAT(I)*PI2/FLOAT(K))
      J=J+1
      IF(J.LE.M) GO TO 210
      RETURN
C****
C****    GAUSSIAN
C****
  300 CONTINUE
      B2=BETA*BETA/2.
  310 I=I+1
      BUF(J)=E**(-1*(((2.*FLOAT(I)/FLOAT(M))**2.)*B2))
      J=J+1
      IF(J.LE.M) GO TO 310
      RETURN
C****
C****     TRIANGULAR
C****
  400 CONTINUE
      K=M/2
      TEMP=FLOAT(K)
      DO 410 I=1,K
      BUF(I)=FLOAT(I-1)/TEMP
      BUF(N-I+1)=BUF(I)
  410 CONTINUE
      BUF(K+1)=1.
      RETURN
C****
C****     RECTANGULAR
C****
  500 CONTINUE
      DO 510 I=1,M
  510 BUF(I)=1.
      RETURN
C****
C****        BLACKMAN
C****
  600 CONTINUE
      A0=.42
      A1=.5
      A2=.08
      A3=0
  610 I=I+1
      TEMP=PI2*FLOAT(I)/FLOAT(K)
      BUF(J)=A0+SGN*A1*COS(TEMP)+A2*COS(TEMP*2)+SGN*A3*COS(TEMP*3)
      J=J+1
      IF(J.LE.M) GO TO 610
      RETURN
C****
C****    EXACT BLACKMAN
C****
  700 CONTINUE
      A0=.42659071
      A1=.49656062
      A2=.07684867
      A3=0.
      GO TO 610
C****
C****      BLACKMAN HARRIS
C****
  800 CONTINUE
      A0=.35875
      A1=.48829
      A2=.14128
      A3=.01168
      GO TO 610
C****
      END


!	Find the negative hessian of the conditional log posterior of an observation
!	relative to the latent vector theta.
!	mask indicates which items are present.
!	condcovs is the arrayr of conditional covariance matrics of scale factors.
!	covs is the array of covariance matrices of scale factors.
!	lintran is the linear transformation of the latent vector.
!	quadth is the matrix parameter for the log density.

function nhesstheta(mask,condcovs,covs,lintran,quadth)
implicit none
interface
	subroutine makesym(matrix)
!	Symmetrize n by n matrix based on lower triangle.
		implicit none
		real(kind=8),intent(inout)::matrix(:,:)
	end subroutine makesym
end interface

logical,intent(in)::mask(:)
real(kind=8),intent(in)::condcovs(:,:,:),covs(:,:,:),lintran(:,:),quadth(:,:)
real(kind=8)::nhesstheta(size(quadth,1),size(quadth,1))

!	col is a column number
!	item is item number.
!	row is a row number
integer::col,item,row
!	Accumulate in itempart.
real(kind=8)::itempart(size(lintran,1),size(lintran,1))

itempart=0.0_8

do item=1,size(mask)
	if(mask(item))then
		do row=1,size(lintran,1)
			do col=1,row
				itempart(row,col)=itempart(row,col)+(covs(row,col,item)-condcovs(row,col,item))
			end do
		end do
	end if
end do
call makesym(itempart)
nhesstheta=-2.0_8*quadth+matmul(transpose(lintran),matmul(itempart,lintran))
return
end function nhesstheta


      subroutine dt3q(d1,q2,t3,edt3q)

      implicit double precision(a-h,o-z)

      dimension d1(3),q2(3,3),t3(3,3,3)

c  this subroutine evaluates the quadrupole-quadrupole
c  electrostatic interaction

      dimension a(10),b(10)

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

      b(1)=d1(1)*q2(1,1)
      b(2)=2.d0*d1(1)*q2(1,2)+d1(2)*q2(1,1)
      b(3)=2.d0*d1(1)*q2(1,3)+d1(3)*q2(1,1)
      b(4)=2.d0*d1(2)*q2(1,2)+d1(1)*q2(2,2)
      b(5)=2.d0*(d1(1)*q2(2,3)+d1(2)*q2(1,3)+d1(3)*q2(1,2))
      b(6)=2.d0*d1(3)*q2(1,3)+d1(1)*q2(3,3)
      b(7)=d1(2)*q2(2,2)
      b(8)=2.d0*d1(2)*q2(2,3)+d1(3)*q2(2,2)
      b(9)=2.d0*d1(3)*q2(2,3)+d1(2)*q2(3,3)
      b(10)=d1(3)*q2(3,3)

      edt3q=a(1)*b(1)+a(2)*b(2)+a(3)*b(3)+a(4)*b(4)+
     .      a(5)*b(5)+a(6)*b(6)+a(7)*b(7)+a(8)*b(8)+a(9)*b(9)+
     .      a(10)*b(10)

      return
      end


!*==csrot.f90  processed by SPAG 7.51RB at 20:37 on  3 Mar 2022
!> \brief \b CSROT
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       SUBROUTINE CSROT( N, CX, INCX, CY, INCY, C, S )
!
!       .. Scalar Arguments ..
!       INTEGER           INCX, INCY, N
!       REAL              C, S
!       ..
!       .. Array Arguments ..
!       COMPLEX           CX( * ), CY( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> CSROT applies a plane rotation, where the cos and sin (c and s) are real
!> and the vectors cx and cy are complex.
!> jack dongarra, linpack, 3/11/78.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>           On entry, N specifies the order of the vectors cx and cy.
!>           N must be at least zero.
!> \endverbatim
!>
!> \param[in,out] CX
!> \verbatim
!>          CX is COMPLEX array, dimension at least
!>           ( 1 + ( N - 1 )*abs( INCX ) ).
!>           Before entry, the incremented array CX must contain the n
!>           element vector cx. On exit, CX is overwritten by the updated
!>           vector cx.
!> \endverbatim
!>
!> \param[in] INCX
!> \verbatim
!>          INCX is INTEGER
!>           On entry, INCX specifies the increment for the elements of
!>           CX. INCX must not be zero.
!> \endverbatim
!>
!> \param[in,out] CY
!> \verbatim
!>          CY is COMPLEX array, dimension at least
!>           ( 1 + ( N - 1 )*abs( INCY ) ).
!>           Before entry, the incremented array CY must contain the n
!>           element vector cy. On exit, CY is overwritten by the updated
!>           vector cy.
!> \endverbatim
!>
!> \param[in] INCY
!> \verbatim
!>          INCY is INTEGER
!>           On entry, INCY specifies the increment for the elements of
!>           CY. INCY must not be zero.
!> \endverbatim
!>
!> \param[in] C
!> \verbatim
!>          C is REAL
!>           On entry, C specifies the cosine, cos.
!> \endverbatim
!>
!> \param[in] S
!> \verbatim
!>          S is REAL
!>           On entry, S specifies the sine, sin.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complex_blas_level1
!
!  =====================================================================
      SUBROUTINE CSROT(N,Cx,Incx,Cy,Incy,C,S)
      IMPLICIT NONE
!*--CSROT102
!
!  -- Reference BLAS level1 routine (version 3.7.0) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      INTEGER Incx , Incy , N
      REAL C , S
!     ..
!     .. Array Arguments ..
      COMPLEX Cx(*) , Cy(*)
!     ..
!
!  =====================================================================
!
!     .. Local Scalars ..
      INTEGER i , ix , iy
      COMPLEX ctemp
!     ..
!     .. Executable Statements ..
!
      IF ( N<=0 ) RETURN
      IF ( Incx==1 .AND. Incy==1 ) THEN
!
!        code for both increments equal to 1
!
         DO i = 1 , N
            ctemp = C*Cx(i) + S*Cy(i)
            Cy(i) = C*Cy(i) - S*Cx(i)
            Cx(i) = ctemp
         ENDDO
      ELSE
!
!        code for unequal increments or equal increments not equal
!          to 1
!
         ix = 1
         iy = 1
         IF ( Incx<0 ) ix = (-N+1)*Incx + 1
         IF ( Incy<0 ) iy = (-N+1)*Incy + 1
         DO i = 1 , N
            ctemp = C*Cx(ix) + S*Cy(iy)
            Cy(iy) = C*Cy(iy) - S*Cx(ix)
            Cx(ix) = ctemp
            ix = ix + Incx
            iy = iy + Incy
         ENDDO
      ENDIF
      END SUBROUTINE CSROT


*       This program calculate the factorial of number n

        write(*,*)'Enter your number to calculate factorial'
        Read(*,*)N
        counter=N
        factorial=1
10      factorial=factorial*counter
        counter=counter-1
        if(counter.EQ.1)   go to 20
        go to 10
20      write(*,*)N,factorial
        stop
        end


      !>@author
      !>Netlib 2019
      !>@copyright Public Domain
      !>@brief
      !> root find a function
      !>Downloaded from Netlib, 2019
      !> with changes by Paul Connolly, University of Manchester
      !>param[in] ax,bx: bounds for root-find
      !>param[in] f: function to be root-found
      !>param[in] tol: tolerance
      !>@return zeroin: location of the zero
c  To get d1mach, mail netlib
c       send d1mach from core
      function zeroin(ax,bx,f,tol)
      use numerics_type
      implicit none
      real(wp), intent(in) :: ax,bx,tol
      real(wp) :: zeroin
      interface
        function f(x)
        use numerics_type
        real(wp), intent(in) :: x
        real(wp) :: f
        end function f
      end interface
c
c      a zero of the function  f(x)  is computed in the interval ax,bx .
c
c  input..
c
c  ax     left endpoint of initial interval
c  bx     right endpoint of initial interval
c  f      function subprogram which evaluates f(x) for any x in
c         the interval  ax,bx
c  tol    desired length of the interval of uncertainty of the
c         final result (.ge.0.)
c
c  output..
c
c  zeroin abscissa approximating a zero of  f  in the interval ax,bx
c
c      it is assumed  that   f(ax)   and   f(bx)   have  opposite  signs
c  this is checked, and an error message is printed if this is not
c  satisfied.   zeroin  returns a zero  x  in the given interval
c  ax,bx  to within a tolerance  4*macheps*abs(x)+tol, where macheps  is
c  the  relative machine precision defined as the smallest representable
c  number such that  1.+macheps .gt. 1.
c      this function subprogram is a slightly  modified  translation  of
c  the algol 60 procedure  zero  given in  richard brent, algorithms for
c  minimization without derivatives, prentice-hall, inc. (1973).
c
      real(wp) ::  a,b,c,d,e,eps,fa,fb,fc,tol1,xm,p,q,r,s,zero
      real(sp) ::  r1mach
      real(dp) ::  d1mach

      if(wp==sp) then
   10   eps = r1mach(4)
      elseif(wp==dp) then
        eps = d1mach(4)
      endif
      tol1 = eps+1.0_wp
c
      a=ax
      b=bx
      fa=f(a)
      fb=f(b)
c     check that f(ax) and f(bx) have different signs
      if (fa .eq.0.0_wp .or. fb .eq. 0.0_wp) go to 20
      if (fa * (fb/abs(fb)) .le. 0.0_wp) go to 20
         write(6,2500)
2500     format(1x,'f(ax) and f(bx) do not have different signs,',
     1             ' zeroin is aborting')
         return
   20 c=a
      fc=fa
      d=b-a
      e=d
   30 if (abs(fc).ge.abs(fb)) go to 40
      a=b
      b=c
      c=a
      fa=fb
      fb=fc
      fc=fa
   40 tol1=2.0_wp*eps*abs(b)+0.5_wp*tol
      xm = 0.5_wp*(c-b)
      if ((abs(xm).le.tol1).or.(fb.eq.0.0_wp)) go to 150
c
c see if a bisection is forced
c
      if ((abs(e).ge.tol1).and.(abs(fa).gt.abs(fb))) go to 50
      d=xm
      e=d
      go to 110
   50 s=fb/fa
      if (a.ne.c) go to 60
c
c linear interpolation
c
      p=2.0_wp*xm*s
      q=1.0_wp-s
      go to 70
c
c inverse quadratic interpolation
c
   60 q=fa/fc
      r=fb/fc
      p=s*(2.0_wp*xm*q*(q-r)-(b-a)*(r-1.0_wp))
      q=(q-1.0_wp)*(r-1.0_wp)*(s-1.0_wp)
   70 if (p.le.0.0_wp) go to 80
      q=-q
      go to 90
   80 p=-p
   90 s=e
      e=d
      if (((2.0_wp*p).ge.(3.0_wp*xm*q-abs(tol1*q))).or.(p.ge.
     *abs(0.5_wp*s*q))) go to 100
      d=p/q
      go to 110
  100 d=xm
      e=d
  110 a=b
      fa=fb
      if (abs(d).le.tol1) go to 120
      b=b+d
      go to 140
  120 if (xm.le.0.0_wp) go to 130
      b=b+tol1
      go to 140
  130 b=b-tol1
  140 fb=f(b)
      if ((fb*(fc/abs(fc))).gt.0.0_wp) go to 20
      go to 30
  150 zeroin=b
      return
      end function zeroin


! Copyright (c) 2017, NVIDIA CORPORATION.  All rights reserved.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.

subroutine sub1
  implicit none

  INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(12,307) !< double precision

  INTEGER,  PARAMETER :: nbndsw   = 14 !< number of spectral bands in sw model
  INTEGER,  PARAMETER :: jpb1     = 16 !< first band in sw
  INTEGER,  PARAMETER :: jpb2     = 29 !< last band in sw

  REAL(dp), PARAMETER :: wavenum2(jpb1:jpb2) = (/ &
    3250._dp, 4000._dp, 4650._dp, 5150._dp, 6150._dp, 7700._dp, 8050._dp, &
    12850._dp,16000._dp,22650._dp,29000._dp,38000._dp,50000._dp, 2600._dp/)

  REAL(dp), PARAMETER :: delwave(jpb1:jpb2)  = (/ &
       650._dp,  750._dp,  650._dp,  500._dp, 1000._dp, 1550._dp,  350._dp, &
       4800._dp, 3150._dp, 6650._dp, 6350._dp, 9000._dp,12000._dp, 1780._dp/)

  REAL (dp), PARAMETER     :: nir_vis_boundary   = 14500._dp

  INTEGER :: i
  REAL(dp),parameter :: frc_vis(1:nbndsw) = MAX(0.0_dp, MIN(1.0_dp, &
    (/ ((wavenum2(i+jpb1-1) - nir_vis_boundary) / delwave(i+jpb1-1), i = 1, nbndsw) /) ))

  PRINT *,frc_vis

END

subroutine sub2
  implicit none

  INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(12,307) !< double precision

  INTEGER,  PARAMETER :: nbndsw   = 14 !< number of spectral bands in sw model
  INTEGER,  PARAMETER :: jpb1     = 16 !< first band in sw
  INTEGER,  PARAMETER :: jpb2     = 29 !< last band in sw

  REAL(dp), PARAMETER :: wavenum2(jpb1:jpb2) = (/ &
    3250._dp, 4000._dp, 4650._dp, 5150._dp, 6150._dp, 7700._dp, 8050._dp, &
    12850._dp,16000._dp,22650._dp,29000._dp,38000._dp,50000._dp, 2600._dp/)

  REAL(dp), PARAMETER :: delwave(jpb1:jpb2)  = (/ &
       650._dp,  750._dp,  650._dp,  500._dp, 1000._dp, 1550._dp,  350._dp, &
       4800._dp, 3150._dp, 6650._dp, 6350._dp, 9000._dp,12000._dp, 1780._dp/)

  REAL (dp), PARAMETER     :: nir_vis_boundary   = 14500._dp
  INTEGER :: i

  REAL(dp), PARAMETER :: temp1(1:nbndsw)  = delwave
  REAL(dp), PARAMETER :: temp2(1:nbndsw)  = wavenum2

  REAL(dp), PARAMETER :: frc_vis(1:nbndsw) = MAX(0.0_dp, MIN(1.0_dp, &
    (/ ((temp2(i) - nir_vis_boundary) / temp1(i), i = 1, nbndsw) /) ))
  real(dp),parameter::x=frc_vis(9)

  PRINT *,"frc_vis:",frc_vis

END

call sub1
call sub2
print *, "PASS"
end


!======================================================================!
  REAL FUNCTION Dist2(xA,yA,zA,xB,yB,zB)
!----------------------------------------------------------------------!
!  Calculates distance between two points.                             !
!----------------------------------------------------------------------!
  IMPLICIT NONE
!-----------------------------[Parameters]-----------------------------!
  REAL :: xA,yA,zA,xB,yB,zB
!--------------------------------[CVS]---------------------------------!
!  $Id: Dist2.f90,v 1.4 2002/10/30 16:29:31 niceno Exp $
!  $Source: /home/muhamed/.CVSROOT/T-Rex/Library/Dist2.f90,v $
!======================================================================!

  Dist2=(xA-xB)*(xA-xB) + (yA-yB)*(yA-yB) + (zA-zB)*(zA-zB)

  END FUNCTION Dist2


PROGRAM LA_CHEEVX_ET_EXAMPLE
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS
   USE LA_PRECISION, ONLY: WP => SP
   USE F95_LAPACK, ONLY: LA_HEEVX
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. PARAMETERS ..
      CHARACTER(LEN=*), PARAMETER :: FMT = '(4(1X,1H(,F7.3,1H,,F7.3,1H):))'
      CHARACTER(LEN=*), PARAMETER :: FMT1 = '(8(1X,F10.3))'
   INTEGER, PARAMETER :: NIN=5, NOUT=6
!  .. LOCAL SCALARS ..
   INTEGER :: I, J, INFO, M, N
!  .. LOCAL ARRAYS ..
   INTEGER, ALLOCATABLE :: IFAIL(:)
   REAL(WP), ALLOCATABLE :: AA(:,:), W(:)
   COMPLEX(WP), ALLOCATABLE :: A(:,:)
!  .. EXECUTABLE STATEMENTS ..
   WRITE(NOUT,*) 'CHEEVX ET_Example Program Results.'
   READ(NIN,*) ! SKIP HEADING IN DATA FILE
   READ(NIN,*) N
   ALLOCATE ( A(N,N), AA(N,N), W(N), IFAIL(N) )
      DO I = 1, N
        READ(NIN,*) (AA(I, J), J = 1, N)
      ENDDO
   A=AA
      WRITE(NOUT,*) 'The matrix A:'
      DO I = 1, N
        WRITE(NOUT,FMT) A(I,:)
      ENDDO
!
   WRITE(NOUT,*) '---------------------------------------------------------'
   WRITE(NOUT,*)
   WRITE ( NOUT, * )'Details of LA_CHEEVX LAPACK Subroutine Results.'
   WRITE(NOUT,*)
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_HEEVX(A, W, INFO=INFO)'
   WRITE(NOUT,*) 'ON ENTRY: A'
   WRITE(NOUT,*) '   A - the original matrix (upper triangular)'
   WRITE(NOUT,*) 'ON EXIT: A, W'
   WRITE(NOUT,*) '   A - destroyed matrix A'
   WRITE(NOUT,*) '   W - the eigenvalues in ascending order'
   A=AA
   W=0
   CALL LA_HEEVX(A,W,INFO=INFO)
   WRITE(NOUT,*) 'The eigenvalues computed by LA_HEEVX:'
   WRITE(NOUT,FMT) W(:)
   WRITE(NOUT,*) 'INFO = ',INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_HEEVX(A, W, 'V', IFAIL=IFAIL)"
   WRITE(NOUT,*) 'ON ENTRY: A'
   WRITE(NOUT,*) '   A - the original matrix (upper triangular)'
   WRITE(NOUT,*) 'ON EXIT: A, W'
   WRITE(NOUT,*) '   A - orthonormal eigenvectors of the matrix A'
   WRITE(NOUT,*) '   W - the eigenvalues in ascending order'
   A=AA
   W=0
   CALL LA_HEEVX(A,W,'V',IFAIL=IFAIL)
   WRITE(NOUT,*) 'The eigenvalues computed by LA_HEEVX:'
   WRITE(NOUT,FMT) W(:)
   WRITE(NOUT,*) 'The orthonormal eigenvectors computed by LA_HEEVX:'
   DO I = 1, N
      WRITE(NOUT,FMT) A(I,:)
   END DO
   WRITE(NOUT,*) 'The values of the vector "IFAIL":'
   WRITE(NOUT,*) IFAIL(:)
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_HEEVX(A, W, 'V', IFAIL=IFAIL, ABSTOL=0.01_WP )"
   WRITE(NOUT,*) 'ON ENTRY: A'
   WRITE(NOUT,*) '   A - the original matrix (upper triangular)'
   WRITE(NOUT,*) '   ABSTOL - the absolute error tolerance for the eigenvalues'
   WRITE(NOUT,*) 'ON EXIT: A, W'
   WRITE(NOUT,*) '   A - orthonormal eigenvectors of the matrix A'
   WRITE(NOUT,*) '   W - the eigenvalues in ascending order'
   A=AA
   W=0
   CALL LA_HEEVX(A,W,'V',IFAIL=IFAIL, ABSTOL=0.01_WP)
   WRITE(NOUT,*) 'The eigenvalues computed by LA_HEEVX:'
   WRITE(NOUT,FMT) W(:)
   WRITE(NOUT,*) 'The orthonormal eigenvectors computed by LA_HEEVX:'
   DO I = 1, N
      WRITE(NOUT,FMT) A(I,:)
   END DO
   WRITE(NOUT,*) 'The values of the vector "IFAIL":'
   WRITE(NOUT,*) IFAIL(:)
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_HEEVX(A, W, 'V', UPLO='L', IFAIL=IFAIL)"
   WRITE(NOUT,*) 'ON ENTRY: A'
   WRITE(NOUT,*) '   A - the original matrix (lower triangular)'
   WRITE(NOUT,*) 'ON EXIT: A, W'
   WRITE(NOUT,*) '   A - orthonormal eigenvectors of the matrix A'
   WRITE(NOUT,*) '   W - the eigenvalues in ascending order'
   A=AA
   W=0
   CALL LA_HEEVX(A,W, 'V', UPLO='L', IFAIL=IFAIL)
   WRITE(NOUT,*) 'The eigenvalues computed by LA_HEEVX:'
   WRITE(NOUT,FMT) W(:)
   WRITE(NOUT,*) 'The orthonormal eigenvectors computed by LA_HEEVX:'
   DO I = 1, N
      WRITE(NOUT,FMT) A(I,:)
   END DO
   WRITE(NOUT,*) 'The values of the vector "IFAIL":'
   WRITE(NOUT,*) IFAIL(:)
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_HEEVX(A, W, UPLO='L')"
   WRITE(NOUT,*) 'ON ENTRY: A'
   WRITE(NOUT,*) '   A - the original matrix (lower triangular)'
   WRITE(NOUT,*) 'ON EXIT: A, W'
   WRITE(NOUT,*) '   A - destroyed matrix A'
   WRITE(NOUT,*) '   W - the eigenvalues in ascending order'
   A=AA
   W=0
   CALL LA_HEEVX(A,W,UPLO='L')
   WRITE(NOUT,*) 'The eigenvalues computed by LA_HEEVX:'
   WRITE(NOUT,FMT) W(:)
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_HEEVX(A, W, JOBZ='V', IFAIL=IFAIL, INFO=INFO)"
   WRITE(NOUT,*) 'ON ENTRY: A'
   WRITE(NOUT,*) '   A - the original matrix (upper triangular)'
   WRITE(NOUT,*) 'ON EXIT: A, W, IFAIL'
   WRITE(NOUT,*) '   A   - orthonormal eigenvectors of the matrix A'
   WRITE(NOUT,*) '   W   - the eigenvalues in ascending order'
   WRITE(NOUT,*) ' IFAIL - the indices of the failed eigenvectors'
   A=AA
   W=0
   IFAIL=0
   CALL LA_HEEVX(A, W, JOBZ='V', IFAIL=IFAIL, INFO=INFO)
   WRITE(NOUT,*) 'The eigenvalues computed by LA_HEEVX:'
   WRITE(NOUT,FMT) W(:)
   WRITE(NOUT,*) 'The orthonormal eigenvectors computed by LA_HEEVX:'
   DO I = 1, N
      WRITE(NOUT,FMT) A(I,:)
   END DO
   WRITE(NOUT,*) 'The indices of the eigenvectors that failed to converge:'
   WRITE(NOUT,*) IFAIL(:)
   WRITE(NOUT,*) 'INFO = ',INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_HEEVX(A, W, 'V', IL=2, IU=3, IFAIL=IFAIL)"
   WRITE(NOUT,*) 'ON ENTRY: A'
   WRITE(NOUT,*) '   A     - the original matrix (upper triangular)'
   WRITE(NOUT,*) '   IL,IU - the indices of the smallest and largest'
   WRITE(NOUT,*) '           eigenvalues to be returned'
   WRITE(NOUT,*) 'ON EXIT: A, W'
   WRITE(NOUT,*) '   A - orthonormal eigenvectors of the matrix A'
   WRITE(NOUT,*) '   W - the eigenvalues in ascending order'
   A=AA
   W=0
   CALL LA_HEEVX(A,W, 'V', IFAIL=IFAIL,IL=2,IU=3)
   WRITE(NOUT,*) 'The eigenvalues computed by LA_HEEVX:'
   WRITE(NOUT,FMT) W(:)
   WRITE(NOUT,*) 'The orthonormal eigenvectors computed by LA_HEEVX:'
   DO I = 1, N
      WRITE(NOUT,FMT) A(I,:)
   END DO
   WRITE(NOUT,*) 'The values of the vector "IFAIL":'
   WRITE(NOUT,*) IFAIL(:)
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_HEEVX(A, W, IFAIL=IFAIL, IL=2)"
   WRITE(NOUT,*) 'ON ENTRY: A'
   WRITE(NOUT,*) '   A     - the original matrix (upper triangular)'
   WRITE(NOUT,*) '   IL,IU - the indices of the smallest and largest'
   WRITE(NOUT,*) '           eigenvalues to be returned (IU = N is assumed).'
   WRITE(NOUT,*) 'ON EXIT: A, W'
   WRITE(NOUT,*) '   A - orthonormal eigenvectors of the matrix A'
   WRITE(NOUT,*) '   W - the eigenvalues in ascending order'
   A=AA
   W=0
   CALL LA_HEEVX(A,W,'V',IFAIL=IFAIL,IL=2)
   WRITE(NOUT,*) 'The eigenvalues computed by LA_HEEVX:'
   WRITE(NOUT,FMT) W(:)
   WRITE(NOUT,*) 'The orthonormal eigenvectors computed by LA_HEEVX:'
   DO I = 1, N
      WRITE(NOUT,FMT) A(I,:)
   END DO
   WRITE(NOUT,*) 'The values of the vector "IFAIL":'
   WRITE(NOUT,*) IFAIL(:)
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_HEEVX(A, W, VL=0.1_WP, VU=4.0_WP, M=M)"
   WRITE(NOUT,*) 'ON ENTRY: A'
   WRITE(NOUT,*) '   A     - the original matrix (upper triangular)'
   WRITE(NOUT,*) '   VL,VU - the lower and upper bounds of the interval'
   WRITE(NOUT,*) '           to be searched for eigenvalues'
   WRITE(NOUT,*) 'ON EXIT: A, W'
   WRITE(NOUT,*) '   A - destroyed matrix A'
   WRITE(NOUT,*) '   W - the eigenvalues in ascending order'
   WRITE(NOUT,*) '   M - the total number of eigenvalues found'
   A=AA
   W=0
   CALL LA_HEEVX(A,W,VL=0.1_WP,VU=4.0_WP,M=M)
   WRITE(NOUT,*) 'The total number of eigenvalues found = ',M
   WRITE(NOUT,*) 'The eigenvalues computed by LA_HEEVX:'
   WRITE(NOUT,FMT1) W(:M)
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_HEEVX(A, W, VU=4.0_WP, M=M)"
   WRITE(NOUT,*) 'ON ENTRY: A'
   WRITE(NOUT,*) '   A     - the original matrix (upper triangular)'
   WRITE(NOUT,*) '   VL,VU - the lower and upper bounds of the interval'
   WRITE(NOUT,*) '           to be searched for eigenvalues (VL = -infinity'
   WRITE(NOUT,*) '           is assumed)'
   WRITE(NOUT,*) 'ON EXIT: A, W'
   WRITE(NOUT,*) '   A - destroyed matrix A'
   WRITE(NOUT,*) '   W - the eigenvalues in ascending order'
   WRITE(NOUT,*) '   M - the total number of eigenvalues found'
   A=AA
   W=0
   CALL LA_HEEVX(A,W,VU=4.0_WP,M=M)
   WRITE(NOUT,*) 'The total number of eigenvalues found = ',M
   WRITE(NOUT,*) 'The eigenvalues computed by LA_HEEVX:'
   WRITE(NOUT,FMT1) W(:M)
!
END PROGRAM LA_CHEEVX_ET_EXAMPLE


program ising
! Lisa Larrimore, lisal@sccs.swarthmore.edu
! 3 May 2002
! Physics 114 Final Project
! This program is adapted from the Ising Model program written in
! BASIC by Elaine Chandler that appears on p. 184 of David Chandler"s
! Introduction to Modern Statistical Mechanics.

 ! The input parameters for this program are in "ising.in", and they
 ! allow the size, length, and initial configuration of the simulation
 ! to be changed. See comments in file.

 ! This program has three output files:
 !
 ! "spin-array" Contains snapshots of the spin lattice at the end of
 ! each temperature run (or throughout the middle of the
 ! run, if only looking at one temperature). Can be
 ! visualized with the IDL program see_spins.pro
 !
 ! "magnetization" Contains four columns: each temperature, the
 ! average magnetization at that temp, the ave magnetizaion
 ! squared at that temp, and the susceptibility.
 !
 ! "energy" Contains four columns: each temperature, the
 ! average energy at that temp, the ave energy squared
 ! at that temp, and the heat capacity.
use iso_fortran_env
 implicit none

 ! Variable declarations:
 integer :: i, j, k,m, n, m2, n2 ! dummy integers
 integer, allocatable :: A(:,:) ! matrix containing spins
 integer :: nrows, ncols ! number of rows and cols of A
 real :: temp, beta ! temperature, inverse temperature
 integer :: ConfigType ! starting configuration type
 integer :: npass ! number of passes for MC algorithm
 integer :: ipass,paso ! the current pass number
 integer :: trial_spin ! values of changed spin
 real :: high_temp ! starting temp for scan
 real :: low_temp ! final temp for scan
 real :: temp_interval ! interval between scan points
 integer :: nscans ! number of scans (each at diff T)
 integer :: average
 integer :: iscan ! current scan number
 logical :: MovieOn ! set to .true. to make movie of 1 temp
 real :: deltaU ! change in energy between 2 configs
 !real :: deltaU1, deltaU ! energy changes for lattice gas
 real :: log_eta ! log of random number to compare to
 real(kind=4) :: magnetization ! magnetization of all spins in lattice
 real(kind=4),allocatable :: magnetization_ave(:) ! cumulative average magnetization
 real(kind=4),allocatable :: magnetizationabs_ave(:) ! cumulative average absolute magnetization
 real(kind=4) :: energy ! energy of all spins in lattice
 real(kind=4),allocatable :: energy_ave(:) ! cumulative average of energy
 real :: alpha(3,3) !alphaud value
 integer :: output_count ! # times things have been added to averages
 real :: invOutput_count,invDim
 character(len=10):: stringTemp,stringAlpha
 character(len=100)::MagFile

 print*, "________________MONTE CARLO 2D ISING MODEL________________"
 print*, "Monte Carlo Statistics for 2D Ising Model with"
 print*, " periodic boundary conditions."
 print*, "The critical temperature is approximately 2.3, as seen on"
 print*, " Chandler p. 123."

 ! Read in input parameters from file "ising.in"
 open(unit=11,file="cf.dat",status="old",action="read")
 read(11,*);read(11,*) nrows
 read(11,*);read(11,*) ncols
 read(11,*);read(11,*) npass
 read(11,*);read(11,*) high_temp
 read(11,*);read(11,*) low_temp
 read(11,*);read(11,*) temp_interval
 read(11,*);read(11,*) alpha(1,3)
 read(11,*);read(11,*) average
 read(11,*);read(11,*) ConfigType
 read(11,*);read(11,*) MovieOn
 close(11)
alpha (3,1) = alpha(1,3)
alpha (1,1) = 1
alpha (3,3) = 1

invDim = 1.0/real(nrows*ncols)
 ! Set the dimensions of the matrix of spin arrays. This program uses
 ! periodic boundary conditions, so the first two rows and columns are
 ! the same as the last two.
 allocate(A(nrows+2,ncols+2))

 ! Open output files:
 !open(unit=32,file="spin-array",status="replace",action="write")
 !write(32,*) nrows
 !write(32,*) ncols
 nscans = int((high_temp - low_temp)/temp_interval) + 1
 !if (MovieOn) then
 !write(32,*) 51
 !write(32,*) 1
 !else
 !write(32,*) nscans
 !write(32,*) 2
 !endif
 allocate(energy_ave(npass))
 allocate(magnetization_ave(npass))
 allocate(magnetizationabs_ave(npass))

 scan_loop: do iscan = 1, nscans
 temp = high_temp - temp_interval*(iscan-1)
 print*, "Running program for T =", temp

 write(stringTemp,'(F7.4)') temp
 write(stringAlpha,'(F7.2)') alpha(1,3)
 MagFile = 'a='//trim(stringAlpha)//'T='//trim(stringTemp)//'.dat'
 call StripSpaces(MagFile)

 ! Initialize variables
 beta = 1.0/temp
 energy_ave(:) = 0.0
 magnetization_ave(:) = 0.0
 magnetizationabs_ave(:) = 0.0

!do i = 1, nrows + 2
!do j = 1, ncols + 2
!A(i,j) = 1
!end do
!end do
aver_loop: do k = 1,average

! Set up the initial spin configuration.
A(1,1) = 1
 do i = 1, nrows+1
 	A(i+1,1) = -A(i,1)
 end do
do j = 1, ncols+1
	A(:,j+1) = -A(:,j)
enddo
 ! Main loop containing Monte Carlo algorithm:
 MC_passes: do ipass = 0, npass

 ! If MovieOn is .true., write the spin array to an output every
 ! npass/50 steps.
 !if ((MovieOn) .and. (mod(ipass,npass/50) == 0)) then
 !do i = 2, nrows+1
 !do j = 2, ncols+1
 !write(32,*) A(i,j)
 !enddo
 !enddo
 !endif

 ! If ipass is greater than nequil (the number of equilibration steps),
 ! calculate the magnetization and energy:

 magnetization = sum(A(2:nrows+1,2:nrows+1))!*invDim!/(ncols*nrows*1.0)
 magnetization_ave(ipass) = magnetization_ave(ipass) + magnetization
 magnetizationabs_ave(ipass) = magnetizationabs_ave(ipass) + abs(magnetization)
 energy = 0.0
 do i = 2, nrows + 1
 do j = 2, ncols + 1
 energy = energy - A(i,j)*(alpha(A(i,j)+2,A(i-1,j)+2)*A(i-1,j)+alpha(A(i,j)+2,A(i+1,j)+2)*A(i+1,j)+alpha(A(i,j)+2,A(i,j-1)+2)*A(i,j-1)+alpha(A(i,j)+2,A(i,j+1)+2)*A(i,j+1))
 !print *, 'InstE: ',A(m,n)*(alpha(A(m,n)+2,A(m-1,n)+2)*A(m-1,n)+alpha(A(m,n)+2,A(m+1,n)+2)*A(m+1,n)+alpha(A(m,n)+2,A(m,n-1)+2)*A(m,n-1)+alpha(A(m,n)+2,A(m,n+1)+2)*A(m,n+1)), 'Energia: ',energy
 enddo
 enddo
 ! Divide the energy by the total number of spins to get the ave
 ! energy per spin, and divide by 2 to account for double counting.
 energy = energy/real(2.0)!*invDim!(ncols*nrows*2.0)
 !print *, 'Energia: ',energy, 'Energia^2: ',energy**2
 energy_ave(ipass) = energy_ave(ipass) + energy
MCloop: do paso=0, nrows*ncols
	 ! Randomly choose a spin to change:
	 m = nint((nrows-1)*ran1(5) + 2) ! choose a random row
	 n = nint((ncols-1)*ran1(5) + 2) ! choose a random column
	 trial_spin = -A(m,n) ! trial spin value

	 ! Find change in energy (deltaU) due to trial move.
	 ! If exp(-beta*deltaU) > eta, where eta is random, accept move:
	 !deltaU = -trial_spin*(A(m-1,n)+A(m+1,n)+A(m,n-1)+A(m,n+1))*2
	  deltaU = -trial_spin* &
			( A(m+1,n)*alpha(trial_spin+2,A(m+1,n)+2) &
			+ A(m-1,n)*alpha(trial_spin+2,A(m-1,n)+2) &
		    + A(m,n+1)*alpha(trial_spin+2,A(m,n+1)+2) &
		    + A(m,n-1)*alpha(trial_spin+2,A(m,n-1)+2) ) &
			+ A(m,n)* &
			( A(m+1,n)*alpha(A(m,n)+2,A(m+1,n)+2) &
			+ A(m-1,n)*alpha(A(m,n)+2,A(m-1,n)+2) &
		    + A(m,n+1)*alpha(A(m,n)+2,A(m,n+1)+2) &
		    + A(m,n-1)*alpha(A(m,n)+2,A(m,n-1)+2) )
	!print *, 'DeltaU: ',deltaU
	 log_eta = dlog(ran1(5) + 1.0d-10) ! random number 0-1 (+ tiny offset)
	 if (-beta*deltaU > log_eta) then
	 A(m,n) = trial_spin
	 if (m == 2) A(nrows+2,n) = trial_spin
	 if (m == nrows+1) A(1,n) = trial_spin
	 if (n == 2) A(m,ncols+2) = trial_spin
	 if (n == ncols+1) A(m,1) = trial_spin
	 endif
	enddo MCloop
 enddo MC_passes

open(unit=33,file=MagFile,status="replace",action="write")
 write(33,*) "average MCS ave_magnetization ave_absmagnetization ave_energy"
do i = 1, npass
 write(33,*) k,i, magnetization_ave(i)/k, magnetizationabs_ave(i)/k, energy_ave(i)/k
end do
 close(33)

end do aver_loop
 ! Write final spin array to output file
 !if (.not. MovieOn) then
 !do i = 2, nrows + 1
 !do j = 2, ncols + 1
 !write(32,*) A(i,j)
 !enddo
 !enddo
 !endif
 enddo scan_loop

 !close(32)

 print*, "Program ising.f90 complete!"
 print*, "Look at spin-array with IDL program see_spins.pro"

 contains

 !_______RANDOM NUMBER GENERATING FUNCTION______!

 double precision function ran1(idum)
 implicit none
 double precision :: r(97)
 integer, intent(IN) :: idum
 save
 integer, parameter :: M1=259200,IA1=7141,IC1=54773
 real, parameter :: RM1=1.0d0/M1
 integer, parameter :: M2=134456,IA2=8121,IC2=28411
 real, parameter :: RM2=1.0d0/M2
 integer, parameter :: M3=243000,IA3=4561,IC3=51349
 integer :: IX1, IX2, IX3, jjj
 integer :: iff=0
 if (idum < 0 .or. iff == 0) then
 iff = 1
 IX1 = mod(IC1-idum,M1)
 IX1 = mod(IA1*IX1+IC1,M1)
 IX2 = mod(IX1,M2)
 IX1 = mod(IA1*IX1+IC1,M1)
 IX3 = mod(IX1,M3)
 do jjj = 1,97
 IX1 = mod(IA1*IX1+IC1,M1)
 IX2 = mod(IA2*IX2+IC2,M2)
 r(jjj) = (dfloat(IX1)+dfloat(IX2)*RM2)*RM1
 end do
 end if
 IX1 = mod(IA1*IX1+IC1,M1)
 IX2 = mod(IA2*IX2+IC2,M2)
 IX3 = mod(IA3*IX3+IC3,M3)
 jjj = 1+(97*IX3)/M3
 if (jjj > 97 .or. jjj < 1)  read( *, * )
 ran1 = r(jjj)
 r(jjj) = (dfloat(IX1)+dfloat(IX2)*RM2)*RM1
 end function ran1

 subroutine StripSpaces(string)
    character(len=*) :: string
    integer :: stringLen
    integer :: last, actual

    stringLen = len (string)
    last = 1
    actual = 1

    do while (actual < stringLen)
        if (string(last:last) == ' ') then
            actual = actual + 1
            string(last:last) = string(actual:actual)
            string(actual:actual) = ' '
        else
            last = last + 1
            if (actual < last) &
                actual = last
        endif
    end do
end subroutine StripSpaces

 end program ising

V6 Out-Of & On Equilibrium/Result Coexistance Phase/Files/Critical Temperature/Internet/Time/ising.f95


module utils
! f2py -c utils.f90 -m futils
use, intrinsic :: iso_fortran_env, only: stderr=>error_unit

implicit none
!private
public :: alt_grid, linspace, cumsum

contains

subroutine argv(i, val)

integer, intent(in) :: i
class(*), intent(out) :: val
character(1024) :: buf
integer :: j, narg

narg = command_argument_count()
if(narg < i) then
  write(stderr,'(A,I0,A,I0)') "Only ",narg, " arguments given, but you requested argument # ", i
  error stop
endif

call get_command_argument(i, buf)

select type(val)
  type is (real)
    read(buf, *, iostat=j) val
  type is (integer)
    read(buf, *, iostat=j) val
  class default
    error stop 'unknown value type'
end select

if(j/=0) then
  write(stderr,*) 'argv: failed to read command line value #',i
  error stop
endif

end subroutine argv

pure real function alt_grid(Nalt, minalt, dmin, dmax)

! * Nalt: number of altitude points
! * altmin: minimum altitude [km]
! * dmin: minimum grid spacing at minimum altitude [km]
! * dmax: maximum grid spacing at maximum altitude [km]
!
! Example: alt = alt_grid(286, 90, 1.5, 11.1475)

real, intent(in) :: dmin, dmax, minalt
integer, intent(in) :: Nalt
real :: dz(Nalt)
dimension :: alt_grid(Nalt)

dz = ztanh(dmin, dmax, Nalt)

alt_grid = cumsum(dz) + minalt-dmin

end function alt_grid

pure real function ztanh(gridmin, gridmax, N)

real, intent(in) :: gridmin, gridmax
integer, intent(in) :: N
real :: x(N)
dimension :: ztanh(N)

x = linspace(0., 3.14, N)
!! arbitrarily picking 3.14 as where tanh gets to 99% of asymptote

ztanh = tanh(x) * gridmax + gridmin

end function ztanh

pure real function linspace(Vmin, Vmax, Nv)

real, intent(in) :: Vmin, Vmax
integer, intent(in) :: Nv
integer :: i
real :: step
dimension :: linspace(Nv)

step = (Vmax - Vmin) / Nv

linspace(1) = Vmin
do i = 2,Nv
  linspace(i) = linspace(i-1) + step
enddo

end function linspace

pure real function cumsum(A)

real, intent(in) :: A(:)
dimension :: cumsum(size(A))
integer :: i

 cumsum(1) = A(1)
 do i = 2,size(A)
   cumsum(i) = cumsum(i-1) + A(i)
 enddo

end function cumsum

end module utils


! ------------------------------------------------------------------
! Programmer(s): David J. Gardner, and Cody J. Balos @ LLNL
! ------------------------------------------------------------------
! SUNDIALS Copyright Start
! Copyright (c) 2002-2020, Lawrence Livermore National Security
! and Southern Methodist University.
! All rights reserved.
!
! See the top-level LICENSE and NOTICE files for details.
!
! SPDX-License-Identifier: BSD-3-Clause
! SUNDIALS Copyright End
! ------------------------------------------------------------------
! Based on cvsAdvDiff_FSA_non.c by Scott D. Cohen, Alan C. Hindmarsh,
! George D. Byrne, and Radu Serban @ LLNL
! -----------------------------------------------------------------
! Example problem:
!
! The following is a simple example problem, with the program for
! its solution by CVODES. The problem is the semi-discrete form of
! the advection-diffusion equation in 1-D:
!   du/dt = q1! d^2 u / dx^2 + q2! du/dx
! on the interval 0 <= x <= 2, and the time interval 0 <= t <= 5.
! Homogeneous Dirichlet boundary conditions are posed, and the
! initial condition is:
!   u(x,y,t=0) = x(2-x)exp(2x).
! The PDE is discretized on a uniform grid of size MX+2 with
! central differencing, and with boundary values eliminated,
! leaving an ODE system of size NEQ = MX.
! This program solves the problem with the option for nonstiff
! systems: ADAMS method and functional iteration.
! It uses scalar relative and absolute tolerances.
! Output is printed at t = .5, 1.0, ..., 5.
! Run statistics (optional outputs) are printed at the end.
!
! Optionally, CVODES can compute sensitivities with respect to the
! problem parameters q1 and q2.
! Any of three sensitivity methods (SIMULTANEOUS, STAGGERED, and
! STAGGERED1) can be used and sensitivities may be included in the
! error test or not (error control set on FULL or PARTIAL,
! respectively).
!
! Execution:
!
! If no sensitivities are desired:
!    % cvsAdvDiff_FSA_non -nosensi
! If sensitivities are to be computed:
!    % cvsAdvDiff_FSA_non -sensi sensi_meth err_con
! where sensi_meth is one of {sim, stg, stg1} and err_con is one of
! {t, f}.
! -----------------------------------------------------------------*/

module ode_problem

  use, intrinsic :: iso_c_binding
  implicit none

  ! problem parameters
  real(c_double),  parameter :: XMAX  = 2.0d0
  real(c_double),  parameter :: T0    = 0.0d0
  real(c_double),  parameter :: T1    = 0.5d0
  real(c_double),  parameter :: DTOUT = 0.5d0
  real(c_double),  parameter :: ATOL  = 1e-5
  integer(c_int),  parameter :: NOUT  = 10
  integer(c_int),  parameter :: NP    = 2
  integer(c_int),  parameter :: NS    = 2
  integer(c_long), parameter :: MX    = 10
  integer(c_long), parameter :: NEQ   = MX

  ! problem constants
  real(c_double) :: ZERO  = 0.d0

  ! problem data
  real(c_double) :: p(0:NP-1)
  real(c_double) :: dx

contains

  ! ----------------------------------------------------------------
  ! RhsFn provides the right hand side function for the
  ! ODE: dy/dt = f(t,y)
  !
  ! Return values:
  !    0 = success,
  !    1 = recoverable error,
  !   -1 = non-recoverable error
  ! ----------------------------------------------------------------
  integer(c_int) function RhsFn(tn, nv_u, nv_udot, user_data) &
    result(ierr) bind(C,name='RhsFn')

    !======= Inclusions ===========
    use, intrinsic :: iso_c_binding
    use fsundials_nvector_mod
    use fnvector_serial_mod

    !======= Declarations =========
    implicit none

    ! calling variables
    real(c_double), value :: tn         ! current time
    type(N_Vector)        :: nv_u       ! solution N_Vector
    type(N_Vector)        :: nv_udot    ! rhs N_Vector
    type(c_ptr),    value :: user_data  ! user-defined data

    ! pointers to data in SUNDIALS vectors
    real(c_double), pointer :: u(:)
    real(c_double), pointer :: udot(:)

    ! problem constants
    real(c_double) :: hordc, horac

    ! temp variables
    real(c_double) :: ui, ult, urt, hdiff, hadv
    integer(c_int) :: i

    ! extract needed problem constants
    hordc = p(0)/(dx*dx)
    horac = p(1)/(2.0d0*dx)

    !======= Internals ============

    ! get data arrays from SUNDIALS vectors
    u    => FN_VGetArrayPointer(nv_u)
    udot => FN_VGetArrayPointer(nv_udot)

    ! loop over all grid points
    do i=1, NEQ
      ui = u(i)

      if (i /= 1) then
        ult = u(i-1)
      else
        ult = ZERO
      endif

      if (i /= NEQ) then
        urt = u(i+1)
      else
        urt = ZERO
      endif

      ! set diffusion and avection terms and load into udot
      hdiff   = hordc*(ult - 2.0d0*ui + urt)
      hadv    = horac*(urt - ult)
      udot(i) = hdiff + hadv
    end do

    ! return success
    ierr = 0
    return

  end function RhsFn

  ! Set initial conditions in u vector.
  subroutine SetIC(nv_u)
    use, intrinsic :: iso_c_binding
    use fsundials_nvector_mod

    implicit none

    type(N_Vector), pointer :: nv_u
    integer(c_int)          :: i
    real(c_double)          :: x
    real(c_double), pointer :: u(:)

    ! Set pointer to data array and get local length of u.
    u => FN_VGetArrayPointer(nv_u)

    ! Load initial profile into u vector
    do i=1, NEQ
      x = i*dx
      u(i) = x*(XMAX - x)*exp(2.0d0*x)
    end do

  end subroutine SetIC

end module ode_problem

program main

  !======= Inclusions ===========
  use, intrinsic :: iso_c_binding

  use fcvodes_mod                   ! Fortran interface to CVODES
  use fnvector_serial_mod           ! Fortran interface to serial N_Vector
  use fsundials_nvector_mod         ! Fortran interface to generic N_Vector
  use fsundials_nonlinearsolver_mod ! Fortran interface to generic SUNNonlinearSolver
  use fsunnonlinsol_fixedpoint_mod  ! Fortran interface to fixed point SUNNonlinearSolver
  use ode_problem                   ! ODE defining functions and parameters

  !======= Declarations =========
  implicit none

  ! Local variables
  type(c_ptr)                       :: cvodes_mem
  type(N_Vector),           pointer :: u, uiS
  type(c_ptr)                       :: uS
  type(SUNNonlinearSolver), pointer :: NLS, NLSsens
  integer(c_int)                    :: iout, retval
  real(c_double)                    :: reltol, abstol, tout, t(1)
  integer(c_int)                    :: is
  real(c_double)                    :: pbar(0:NS-1)
  integer(c_int)                    :: plist(0:NS-1)

  ! Command line arguments
  integer(c_int) :: sensi, err_con
  integer(c_int) :: sensi_meth

  ! Process arguments
  call ProcessArgs(sensi, sensi_meth, err_con)

  ! Set problem data
  dx   = XMAX/(MX+1)
  p(0) = 1.0d0
  p(1) = 0.5d0

  ! Allocate and set initial states
  u => FN_VNew_Serial(NEQ)
  if (.not. associated(u)) then
    write(*,*) 'ERROR: FN_VNew_Serial returned NULL'
    stop 1
  endif
  call SetIC(u)

  ! Set integration tolerances
  reltol = ZERO
  abstol = ATOL

  ! Create CVODES object
  cvodes_mem = FCVodeCreate(CV_ADAMS)
  if (.not. c_associated(cvodes_mem)) then
    write(*,*) 'ERROR: cvodes_mem = NULL'
    stop 1
  endif

  ! Initialize CVode
  retval = FCVodeInit(cvodes_mem, c_funloc(RhsFn), T0, u)
  call check_retval(retval, "FCVodeInit")

  ! Set relative and absolute tolerences
  retval = FCVodeSStolerances(cvodes_mem, reltol, abstol)
  call check_retval(retval, "FCVodeSStolerances")

  ! Create fixed point nonlinear solver object
  NLS => FSUNNonlinSol_FixedPoint(u, 0)
  if (.not. associated(NLS)) then
    write(*,*) 'ERROR: FSUNNonlinSol_FixedPoint returned NULL'
    stop 1
  endif

  ! Attach nonlinear solver object to CVode
  retval = FCVodeSetNonlinearSolver(cvodes_mem, NLS)
  call check_retval(retval, "FCVodeSetNonlinearSolver")

  write(*,*) ""
  print '(A,i3)', "1-D advection-diffusion equation, mesh size =", MX

  ! Sensitivity-related settings
  if (sensi /= 0) then

    do is=0, NS-1
      plist(is) = is
      pbar(is)  = p(plist(is))
    end do

    uS = FN_VCloneVectorArray(NS, u)
    if (.not. c_associated(uS)) then
      write(*,*) 'ERROR: FN_VCloneVectorArray returned NULL'
      stop 1
    endif

    do is=0, NS-1
      uiS => FN_VGetVecAtIndexVectorArray(uS, is)
      call FN_VConst(ZERO, uiS)
    end do

    retval = FCVodeSensInit1(cvodes_mem, NS, sensi_meth, c_null_funptr, uS)
    call check_retval(retval, "FCVodeSensInit1")

    retval = FCVodeSensEEtolerances(cvodes_mem)
    call check_retval(retval, "FCVodeSensEEtolerances")

    retval = FCVodeSetSensErrCon(cvodes_mem, err_con)
    call check_retval(retval, "FCVodeSetSensErrCon")

    retval = FCVodeSetSensDQMethod(cvodes_mem, CV_CENTERED, ZERO)
    call check_retval(retval, "FCVodeSetSensDQMethod")

    retval = FCVodeSetSensParams(cvodes_mem, p, pbar, plist)
    call check_retval(retval, "FCVodeSetSensParams")

    ! create sensitivity fixed point nonlinear solver object
    if (sensi_meth == CV_SIMULTANEOUS) then
      NLSsens => FSUNNonlinSol_FixedPointSens(NS+1, u, 0)
    else if (sensi_meth == CV_STAGGERED) then
      NLSsens => FSUNNonlinSol_FixedPointSens(NS, u, 0)
    else
      NLSsens => FSUNNonlinSol_FixedPoint(u, 0)
    endif

    if (.not. associated(NLSsens)) then
      write(*,*) 'ERROR: FSUNNonlinSol_FixedPointSens returned NULL'
      stop 1
    endif

    ! attach nonlinear solver object to CVode
    if (sensi_meth == CV_SIMULTANEOUS) then
      retval = FCVodeSetNonlinearSolverSensSim(cvodes_mem, NLSsens)
    else if (sensi_meth == CV_STAGGERED) then
      retval = FCVodeSetNonlinearSolverSensStg(cvodes_mem, NLSsens)
    else
      retval = FCVodeSetNonlinearSolverSensStg1(cvodes_mem, NLSsens)
    endif

    call check_retval(retval, "FCVodeSetNonlinearSolverSens")

    write(*,'(A)',advance="no") "Sensitivity: YES "
    if (sensi_meth == CV_SIMULTANEOUS) then
      write(*,'(A)',advance="no") "( SIMULTANEOUS +"
    else
      if (sensi_meth == CV_STAGGERED) then
        write(*,'(A)',advance="no") "( STAGGERED +"
      else
        write(*,'(A)',advance="no") "( STAGGERED1 +"
      endif
    endif

    if (err_con /= 0) then
      write(*,'(A)',advance="no") " FULL ERROR CONTROL )"
    else
      write(*,'(A)',advance="no") " PARTIAL ERROR CONTROL )"
    endif

  else

    write(*,'(A)') "Sensitivity: NO "

  endif

  ! In loop over output points, call CVode, print results, test for error

  write(*,*) ""
  write(*,*) ""
  write(*,*) "============================================================"
  write(*,*) "     T     Q       H      NST                    Max norm   "
  write(*,*) "============================================================"

  tout = T1
  do iout = 1, NOUT
    retval = FCVode(cvodes_mem, tout, u, t, CV_NORMAL)
    call check_retval(retval, "FCVode")

    call PrintOutput(cvodes_mem, t, u)

    if (sensi /= 0) then
      retval = FCVodeGetSens(cvodes_mem, t, uS)
      call check_retval(retval, "FCVodeGetSens")
      call PrintOutputS(uS)
    endif

    write(*,*) "------------------------------------------------------------"

    tout = tout + DTOUT
  end do

  ! Print final statistics
  call PrintFinalStats(cvodes_mem, sensi, err_con, sensi_meth)

  ! Free memory
  call FN_VDestroy(u)
  if (sensi /= 0) then
    call FN_VDestroyVectorArray(uS, NS)
  endif

  call FCVodeFree(cvodes_mem)
  retval = FSUNNonlinSolFree(NLS)
  if (sensi /= 0) then
    retval = FSUNNonlinSolFree(NLSsens)
  endif

end program main

! Process and verify arguments.
subroutine ProcessArgs(sensi, sensi_meth, err_con)
  use, intrinsic :: iso_c_binding
  use fcvodes_mod
  implicit none

  integer(c_int)    :: sensi, sensi_meth, err_con
  integer(c_int)    :: argc
  character(len=32) :: arg

  argc       = command_argument_count()
  sensi      = 0
  sensi_meth = -1
  err_con    = 0

  if (argc < 1) then
    call WrongArgs()
  endif

  call get_command_argument(1, arg)
  if (arg == "-nosensi") then
    sensi = 0
  else if (arg == "-sensi") then
    sensi = 1
  else
    call WrongArgs()
  endif

  if (sensi /= 0) then

    if (argc /= 3) then
      call WrongArgs()
    endif

    call get_command_argument(2, arg)
    if (arg == "sim") then
      sensi_meth = CV_SIMULTANEOUS
    else if (arg == "stg") then
      sensi_meth = CV_STAGGERED
    else if (arg == "stg1") then
      sensi_meth = CV_STAGGERED1
    else
      call WrongArgs()
    endif

    call get_command_argument(3, arg)
    if (arg == "t") then
      err_con = 1
    else if (arg == "f") then
      err_con = 0
    else
      call WrongArgs()
    endif

  endif
end subroutine

! Print help.
subroutine WrongArgs()
  write(*,*) ""
  write(*,*) "Usage: ./cvsAdvDiff_FSA_non [-nosensi] [-sensi sensi_meth err_con]"
  write(*,*) "         sensi_meth = sim, stg, or stg1"
  write(*,*) "         err_con    = t or f"
  write(*,*) ""
  call exit(0)
end subroutine

! Print the current number of steps, order, stepsize, and max norm of solution
subroutine PrintOutput(cvodes_mem, t, u)
  use, intrinsic :: iso_c_binding
  use fcvodes_mod
  use fsundials_nvector_mod
  implicit none

  ! subroutine args
  type(c_ptr)    :: cvodes_mem
  real(c_double) :: t(1)
  type(N_Vector) :: u

  ! local variables
  integer(c_int)  :: retval
  integer(c_long) :: nst(1)
  integer(c_int)  :: qu(1)
  real(c_double)  :: hu(1)
  real(c_double)  :: unorm

  retval = FCVodeGetNumSteps(cvodes_mem, nst)
  retval = FCVodeGetLastOrder(cvodes_mem, qu)
  retval = FCVodeGetLastStep(cvodes_mem, hu)

  write(*,'(1x,es9.3,1x,i2,2x,es9.3,i5)') t, qu, hu, nst

  unorm = FN_VMaxNorm(u)
  write(*,'(1x,A,es12.4)') "                                Solution        ", unorm

end subroutine

subroutine PrintOutputS(uS)
  use, intrinsic :: iso_c_binding
  use fsundials_nvector_mod

  ! subroutine args
  type(c_ptr) :: uS

  ! local variables
  type(N_Vector), pointer :: uiS
  real(c_double)          :: norm

  uiS => FN_VGetVecAtIndexVectorArray(uS, 0)
  norm = FN_VMaxNorm(uiS)
  write(*,'(1x,A,es12.4)') "                                Sensitivity 1   ", norm
  uiS => FN_VGetVecAtIndexVectorArray(uS, 1)
  norm = FN_VMaxNorm(uiS)
  write(*,'(1x,A,es12.4)') "                                Sensitivity 2   ", norm

end subroutine

subroutine PrintFinalStats(cvodes_mem, sensi, err_con, sensi_meth)
  use, intrinsic :: iso_c_binding
  use fcvodes_mod
  implicit none

  ! subroutine args
  type(c_ptr)      :: cvodes_mem
  integer(c_int)   :: sensi, err_con, sensi_meth

  ! local variables
  integer(c_int)  :: retval
  integer(c_long) :: nst(1), nfe(1), nsetups(1), netf(1), nni(1), ncfn(1), &
                     nfSe(1), nfeS(1), nsetupsS(1), netfS(1), nniS(1), ncfnS(1)

  retval = FCVodeGetNumSteps(cvodes_mem, nst)
  retval = FCVodeGetNumRhsEvals(cvodes_mem, nfe)
  retval = FCVodeGetNumLinSolvSetups(cvodes_mem, nsetups)
  retval = FCVodeGetNumErrTestFails(cvodes_mem, netf)
  retval = FCVodeGetNumNonlinSolvIters(cvodes_mem, nni)
  retval = FCVodeGetNumNonlinSolvConvFails(cvodes_mem, ncfn)

  if (sensi /= 0) then

    retval = FCVodeGetSensNumRhsEvals(cvodes_mem, nfSe)
    retval = FCVodeGetNumRhsEvalsSens(cvodes_mem, nfeS)
    retval = FCVodeGetSensNumLinSolvSetups(cvodes_mem, nsetupsS)

    if (err_con /= 0) then
      retval = FCVodeGetSensNumErrTestFails(cvodes_mem, netfS)
    else
      netfS = 0
    endif

    if (sensi_meth == CV_STAGGERED .or. sensi_meth == CV_STAGGERED1) then
      retval = FCVodeGetSensNumNonlinSolvIters(cvodes_mem, nniS)
      retval = FCVodeGetSensNumNonlinSolvConvFails(cvodes_mem, ncfnS)
    else
      nniS  = 0
      ncfnS = 0
    endif

  endif

  write(*,*) ""
  write(*,*) "Final Statistics"
  write(*,*) ""
  write(*,'(1x,A,i9)')        "nst     =", nst
  write(*,'(1x,A,i9)')        "nfe     =", nfe
  write(*,'(1x,A,i9,A,i9)')   "nst     =", netf,  "    nsetups   =", nsetups
  write(*,'(1x,A,i9,A,i9)')   "nni     =", nni,   "    ncfn      =", ncfn

  if (sensi /= 0) then
    write(*,*) ""
    write(*,'(1x,A,i9,A,i9)') "nfSe    =", nfSe,  "    nfeS      =", nfeS
    write(*,'(1x,A,i9,A,i9)') "netfS   =", netfS, "    nsetupsS  =", nsetupsS
    write(*,'(1x,A,i9,A,i9)') "nniS    =", nniS,  "    ncfnS     =", ncfnS
  endif

end subroutine

subroutine check_retval(retval, name)
  use, intrinsic :: iso_c_binding

  character(len=*) :: name
  integer(c_int)   :: retval

  if (retval /= 0) then
    write(*,'(A,A,A)') 'ERROR: ', name,' returned nonzero'
    stop 1
  end if
end subroutine


      program p1

      integer i, total

      total = 0

      do i = 1, 999
          if (mod(i, 3) .eq. 0 .or. mod(i, 5) .eq. 0) then
              total = total + i
          endif
      end do

      print *, 'total = ', total

      end


      PROGRAM sfroid
      INTEGER NE,M,NB,NCI,NCJ,NCK,NSI,NSJ,NYJ,NYK
      COMMON /sfrcom/ x,h,mm,n,c2,anorm
      PARAMETER (NE=3,M=41,NB=1,NCI=NE,NCJ=NE-NB+1,NCK=M+1,NSI=NE,NSJ=2*
     *NE+1,NYJ=NE,NYK=M)
CU    USES plgndr,solvde
      INTEGER i,itmax,k,mm,n,indexv(NE)
      REAL anorm,c2,conv,deriv,fac1,fac2,h,q1,slowc,c(NCI,NCJ,NCK),
     *s(NSI,NSJ),scalv(NE),x(M),y(NE,M),plgndr
      itmax=100
      conv=5.e-6
      slowc=1.
      h=1./(M-1)
      c2=0.
      write(*,*)'ENTER M,N'
      read(*,*)mm,n
      if(mod(n+mm,2).eq.1)then
        indexv(1)=1
        indexv(2)=2
        indexv(3)=3
      else
        indexv(1)=2
        indexv(2)=1
        indexv(3)=3
      endif
      anorm=1.
      if(mm.NE.0)then
        q1=n
        do 11 i=1,mm
          anorm=-.5*anorm*(n+i)*(q1/i)
          q1=q1-1.
11      continue
      endif
      do 12 k=1,M-1
        x(k)=(k-1)*h
        fac1=1.-x(k)**2
        fac2=fac1**(-mm/2.)
        y(1,k)=plgndr(n,mm,x(k))*fac2
        deriv=-((n-mm+1)*plgndr(n+1,mm,x(k))-(n+1)*x(k)*plgndr(n,mm,
     *x(k)))/fac1
        y(2,k)=mm*x(k)*y(1,k)/fac1+deriv*fac2
        y(3,k)=n*(n+1)-mm*(mm+1)
12    continue
      x(M)=1.
      y(1,M)=anorm
      y(3,M)=n*(n+1)-mm*(mm+1)
      y(2,M)=(y(3,M)-c2)*y(1,M)/(2.*(mm+1.))
      scalv(1)=abs(anorm)
      scalv(2)=max(abs(anorm),y(2,M))
      scalv(3)=max(1.,y(3,M))
1     continue
      write (*,*) 'ENTER C**2 OR 999 TO END'
      read (*,*) c2
      if (c2.eq.999.) stop
      call solvde(itmax,conv,slowc,scalv,indexv,NE,NB,M,y,NYJ,NYK,c,NCI,
     *NCJ,NCK,s,NSI,NSJ)
      write (*,*) ' M = ',mm,'  N = ',n,'  C**2 = ',c2,'  LAMBDA = ',
     *y(3,1)+mm*(mm+1)
      goto 1
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/sfroid.for


module MLP_layer
  implicit none
  private
  public :: layer_type
  type :: layer_type
    real(8), allocatable :: W(:,:) ! weights
    real(8), allocatable :: b(:)     ! biases
    real(8), allocatable :: z(:)      ! arg. to activation function
    real(8), allocatable :: a(:)     ! activations
  end type layer_type
end module MLP_layer


! STIFFNESS_CONVERSIONS
! dSdE_2_dPdF       Convert dSdE to dPdF
! dSdE_2_dtaudF     Convert dSdE to d(tau)dF
! dPdF_2_dtaudF     Convert dPdF to d(tau)dF

Module Stiffness_Conversions
use Conversions
use Open_products
use Contractions
use Standard_tensors
use Operations
Implicit none
    CONTAINS

!==============================================================================
FUNCTION dSdE_2_dPdF(dSdE,F,S) result(dPdF)
   implicit none
   double precision, intent(in) :: dSdE(9,9), F(9), S(9)
   double precision             :: dPdF(9,9), I2(9), Ft(9)
    I2 = eye_V9()
    Ft = trans_V9(F)
    dPdF = op_a_V9(I2, S) + (1/2)*V9x9_dd_V9x9(V9x9_dd_V9x9(op_a_V9(F, I2), dSdE), op_b_V9(I2, Ft)+op_a_V9(Ft,I2))

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

!==============================================================================
FUNCTION dSdE_2_dtaudF(dSdE,F,S) result(dtaudF)
    !S = 2nd Piola Kirchoff
    !E = 0.5(C-I2), C=F^T*F
    !F = Deformation gradient
   implicit none
   double precision, intent(in) :: dSdE(9,9), F(9), S(9)
   double precision             :: dtaudF(9,9), I2(9), Ft(9)
    I2 = eye_V9()
    Ft = trans_V9(F)
    dtaudF = op_a_V9(I2, V9_d_V9(F, S)) + op_b_V9(V9_d_V9(F, S), I2) &
        + 0.5*V9x9_dd_V9x9(V9x9_dd_V9x9(op_a_V9(F, F), dSdE), op_b_V9(I2, Ft)+op_a_V9(Ft, I2))

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

!==============================================================================
FUNCTION dPdF_2_dtaudF(dPdF,F,P) result(dtaudF)
   implicit none
   double precision, intent(in) :: dPdF(9,9), F(9), P(9)
   double precision             :: dtaudF(9,9), I2(9), Ft(9)
    I2 = eye_V9()
    Ft = trans_V9(F)
    dtaudF = V9x9_dd_V9x9(op_a_V9(I2, F), dPdF) + op_b_V9(P, I2)

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

end module


!=============================================================================!
        subroutine g2(v, g2v, ny, dy, opty, yper)
!
!  Take the gradient in the wall normal direction
!  updated to fourth order accurate differencing
!
!=============================================================================!
        use stencil
        implicit none

        integer ny, opty
        logical :: yper
        real v(ny), g2v(ny), dy

        real,parameter :: one = 1.0
        real dyinv
        real a, b, c, w
        real gy1, gy2, gy3, gy4, gy5, gy6
!=============================================================================!

        dyinv  = one / dy

!.... seven point stencil in y

        if (opty.eq.0) then
          c = 1.0 / 60.0
        else
          w = 2.0 * 3.1415926535897932385e+0 / 12.0
          c = (w/2.0 - 2.0*Sin(w)/3.0 + Sin(2.0*w)/12.0) / &
              (5.0*Sin(w) - 4.0*Sin(2.0*w) + Sin(3.0*w))
        end if

        a = (2.0 + 15.0 * c) / 3.0
        b = -(1.0 + 48.0 * c) / 12.0

        gy1 =  -c * dyinv
        gy2 =  -b * dyinv
        gy3 =  -a * dyinv
        gy4 =   a * dyinv
        gy5 =   b * dyinv
        gy6 =   c * dyinv

!=============================================================================!
!.... compute the gradient in y
!=============================================================================!

        if (yper) then

          g2v(1)       = ( gy1 * v(ny-3)        + &
                                gy2 * v(ny-2)   + &
                                gy3 * v(ny-1)   + &
                                gy4 * v(2)      + &
                                gy5 * v(3)      + &
                                gy6 * v(4)      )

          g2v(2)       = ( gy1 * v(ny-2)        + &
                                gy2 * v(ny-1)   + &
                                gy3 * v(1)      + &
                                gy4 * v(3)      + &
                                gy5 * v(4)      + &
                                gy6 * v(5)      )

          g2v(3)       = ( gy1 * v(ny-1)        + &
                                gy2 * v(1)      + &
                                gy3 * v(2)      + &
                                gy4 * v(4)      + &
                                gy5 * v(5)      + &
                                gy6 * v(6)      )

          g2v(ny-2)    = ( gy1 * v(ny-5)        + &
                                gy2 * v(ny-4)   + &
                                gy3 * v(ny-3)   + &
                                gy4 * v(ny-1)   + &
                                gy5 * v(1)      + &
                                gy6 * v(2)      )

          g2v(ny-1)    = ( gy1 * v(ny-4)        + &
                                gy2 * v(ny-3)   + &
                                gy3 * v(ny-2)   + &
                                gy4 * v(1)      + &
                                gy5 * v(2)      + &
                                gy6 * v(3)      )

          g2v(ny) = g2v(1)

        else

          g2v(1)     = ( gc1 * v(1)  + &
                              gc2 * v(2)  + &
                              gc3 * v(3)  + &
                              gc4 * v(4)  + &
                              gc5 * v(5)  ) * dyinv

          g2v(2)     = ( gb1 * v(1)  + &
                              gb2 * v(2)  + &
                              gb3 * v(3)  + &
                              gb4 * v(4)  + &
                              gb5 * v(5)  ) * dyinv

          g2v(3)     = ( ga1 * v(1)  + &
                              ga2 * v(2)  + &
                              ga3 * v(4)  + &
                              ga4 * v(5)  ) * dyinv

          g2v(ny-2)  = ( ga1 * v(ny-4)  + &
                              ga2 * v(ny-3)  + &
                              ga3 * v(ny-1)  + &
                              ga4 * v(ny  )  ) * dyinv

          g2v(ny-1) = -( gb1 * v(ny  )  + &
                              gb2 * v(ny-1)  + &
                              gb3 * v(ny-2)  + &
                              gb4 * v(ny-3)  + &
                              gb5 * v(ny-4)  ) * dyinv

          g2v(ny)   = -( gc1 * v(ny  )  + &
                              gc2 * v(ny-1)  + &
                              gc3 * v(ny-2)  + &
                              gc4 * v(ny-3)  + &
                              gc5 * v(ny-4)  ) * dyinv

        end if

!.... interior

        g2v(4:ny-3) = ( gy1 * v(1:ny-6) + &
                             gy2 * v(2:ny-5)    + &
                             gy3 * v(3:ny-4)    + &
                             gy4 * v(5:ny-2)    + &
                             gy5 * v(6:ny-1)    + &
                             gy6 * v(7:ny  )    )

        return
        end


      SUBROUTINE slDSC6 (A, B, R, AD, BD, RD, V)
*+
*     - - - - - -
*      D S C 6
*     - - - - - -
*
*  Conversion of position & velocity in spherical coordinates
*  to Cartesian coordinates
*
*  (double precision)
*
*  Given:
*     A     dp      longitude (radians)
*     B     dp      latitude (radians)
*     R     dp      radial coordinate
*     AD    dp      longitude derivative (radians per unit time)
*     BD    dp      latitude derivative (radians per unit time)
*     RD    dp      radial derivative
*
*  Returned:
*     V     dp(6)   Cartesian position & velocity vector
*
*  P.T.Wallace   Starlink   10 July 1993
*
*  Copyright (C) 1995 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION A,B,R,AD,BD,RD,V(6)

      DOUBLE PRECISION SA,CA,SB,CB,RCB,X,Y,RBD,W

*  Useful functions
      SA=SIN(A)
      CA=COS(A)
      SB=SIN(B)
      CB=COS(B)
      RCB=R*CB
      X=RCB*CA
      Y=RCB*SA
      RBD=R*BD
      W=RBD*SB-CB*RD

*  Position
      V(1)=X
      V(2)=Y
      V(3)=R*SB

*  Velocity
      V(4)=-Y*AD-W*CA
      V(5)=X*AD-W*SA
      V(6)=RBD*CB+SB*RD

      END


!> \file sw_ptmp.f90
!! \BRIEF
!> Module with sw_ptmp function - compute potential T from in-situ T
MODULE msw_ptmp
CONTAINS
!> Function to calculate potential temperature [C] from in-situ temperature
FUNCTION sw_ptmp  (s,t,p,pr)

  !     ==================================================================
  !     Calculates potential temperature [C] from in-situ Temperature [C]
  !     From UNESCO 1983 report.
  !     Armin Koehl akoehl@ucsd.edu
  !     ==================================================================

  !     Input arguments:
  !     -------------------------------------
  !     s  = salinity            [psu      (PSS-78) ]
  !     t  = temperature         [degree C (IPTS-68)]
  !     p  = pressure            [db]
  !     pr = reference pressure  [db]

  USE msingledouble
  USE msw_adtg
  IMPLICIT NONE

! Input arguments
  !> salinity [psu (PSS-78)]
  REAL(kind=r8) :: s
  !> temperature [degree C (IPTS-68)]
  REAL(kind=r8) :: t
  !> pressure [db]
  REAL(kind=r8) :: p
  !> reference pressure  [db]
  REAL(kind=r8) :: pr

! local arguments
  REAL(kind=r8) :: del_P ,del_th, th, q
  REAL(kind=r8) :: onehalf, two, three
  PARAMETER (onehalf = 0.5d0, two = 2.d0, three = 3.d0 )

! REAL(kind=r8) :: sw_adtg
! EXTERNAL sw_adtg

! Output
  REAL(kind=r8) :: sw_ptmp

  ! theta1
  del_P  = PR - P
  del_th = del_P*sw_adtg(S,T,P)
  th     = T + onehalf*del_th
  q      = del_th

  ! theta2
  del_th = del_P*sw_adtg(S,th,P+onehalf*del_P)
  th     = th + (1.d0 - 1.d0/SQRT(two))*(del_th - q)
  q      = (two-SQRT(two))*del_th + (-two+three/SQRT(two))*q

  ! theta3
  del_th = del_P*sw_adtg(S,th,P+onehalf*del_P)
  th     = th + (1.d0 + 1.d0/SQRT(two))*(del_th - q)
  q      = (two + SQRT(two))*del_th + (-two-three/SQRT(two))*q

  ! theta4
  del_th = del_P*sw_adtg(S,th,P+del_P)
  sw_ptmp     = th + (del_th - two*q)/(two*three)

  RETURN
END FUNCTION sw_ptmp

!> Function to calculate potential temperature [C] from in-situ temperature
!! and derivative with respect to insitu temperature and salinity
FUNCTION sw_ptmp_DNAD  (s,t,p,pr)

  !     It is similar to subroutine 'sw_ptmp' above except that it also computes
  !     partial derivative of potential temperature
  !     with respect to insitu temperature and salinity.
  !     ==================================================================
  !     Calculates potential temperature [C] from in-situ Temperature [C]
  !     From UNESCO 1983 report.
  !     Armin Koehl akoehl@ucsd.edu
  !     ==================================================================

  !     Input arguments:
  !     -------------------------------------
  !     s  = salinity            [psu      (PSS-78) ]
  !     t  = temperature         [degree C (IPTS-68)]
  !     p  = pressure            [db]
  !     pr = reference pressure  [db]

  USE msingledouble
  USE msw_adtg
  USE Dual_Num_Auto_Diff
  IMPLICIT NONE

! Input arguments
  !> salinity [psu (PSS-78)]
  TYPE(DUAL_NUM) :: s
  !> temperature [degree C (IPTS-68)]
  TYPE(DUAL_NUM) :: t
  !> pressure [db]
  TYPE(DUAL_NUM) :: p
  !> reference pressure  [db]
  TYPE(DUAL_NUM) :: pr

! local arguments
  TYPE(DUAL_NUM) :: del_P ,del_th, th, q
  REAL(kind=r8) :: onehalf, two, three
  PARAMETER (onehalf = 0.5d0, two = 2.d0, three = 3.d0 )

! Output
  TYPE(DUAL_NUM) :: sw_ptmp_DNAD

  ! theta1
  del_P  = PR - P
  del_th = del_P*sw_adtg_DNAD(S,T,P)
  th     = T + onehalf*del_th
  q      = del_th

  ! theta2
  del_th = del_P*sw_adtg_DNAD(S,th,P+onehalf*del_P)
  th     = th + (1.d0 - 1.d0/SQRT(two))*(del_th - q)
  q      = (two-SQRT(two))*del_th + (-two+three/SQRT(two))*q

  ! theta3
  del_th = del_P*sw_adtg_DNAD(S,th,P+onehalf*del_P)
  th     = th + (1.d0 + 1.d0/SQRT(two))*(del_th - q)
  q      = (two + SQRT(two))*del_th + (-two-three/SQRT(two))*q

  ! theta4
  del_th = del_P*sw_adtg_DNAD(S,th,P+del_P)
  sw_ptmp_DNAD  = th + (del_th - two*q)/(two*three)

  RETURN
END FUNCTION sw_ptmp_DNAD
END MODULE msw_ptmp


subroutine calc_OBJPOT
    use params
    implicit none
    OBJPOT = 0.0d0
    !Shin Experiment
    if (doShin) then
        call calc_OBJPOT_shin
    else
        if (enablePot) then
            if(potType .eq. 0) then
                call calc_OBJPOT_obj
            end if
            if(potType .eq. 1) then
                call calc_OBJPOT_rot
            end if
            if(potType .eq. 2) then
                call calc_OBJPOT_pins_square
            end if
            if(potType .eq. 4) then
                call calc_OBJPOT_img
            end if
        end if
        if (enableTrap) then
            if (trapType .eq. 0) then
                call add_harmonic_trap
            end if
            if (trapType .eq. 1) then
                call add_hard_circle_trap
            end if
            if (trapType .eq. 2) then
                call add_hard_box_trap
            end if
            if (trapType .eq. 3) then
                call add_soft_circle_trap
            end if
            if (trapType .eq. 4) then
                call add_soft_box_trap
            end if

        end if
    end if

end subroutine

subroutine add_harmonic_trap
    use params
    implicit none
    integer :: i,j
    double precision :: rx,ry
    !$OMP PARALLEL DO
    do i = -NX/2,NX/2
    do j = -NY/2,NY/2
        rx = (dble(i)*DSPACE)-TXDASH-(TRAPAMP*sin(TRAPW*TIME))
        ry = (dble(j)*DSPACE)-TYDASH
        OBJPOT(i,j) = OBJPOT(i,j) + 0.5d0*(TXSCALE*rx**2.0 + TYSCALE*ry**2.0)
    end do
    end do
    !$OMP END PARALLEL DO
end subroutine

subroutine add_soft_circle_trap
    use params
    implicit none
    integer :: i,j
    double precision :: rx,ry,r
    !$OMP PARALLEL DO
    do i = -NX/2,NX/2
    do j = -NY/2,NY/2
        rx = (dble(i)*DSPACE)-TXDASH-(TRAPAMP*sin(TRAPW*TIME))
        ry = (dble(j)*DSPACE)-TYDASH
        r = SQRT(rx**2.0+ry**2.0)
        OBJPOT(i,j) = OBJPOT(i,j)+TRAPHEIGHT/(1.0d0+EXP(-TRAPBETA*(ABS(r)-TRAPR)))
    end do
    end do
    !$OMP END PARALLEL DO
end subroutine

subroutine add_hard_circle_trap
    use params
    implicit none
    integer :: i,j
    double precision :: rx,ry,r
    !$OMP PARALLEL DO
    do i = -NX/2,NX/2
    do j = -NY/2,NY/2
        rx = (dble(i)*DSPACE)-TXDASH
        ry = (dble(j)*DSPACE)-TYDASH
        r = SQRT(rx**2.0+ry**2.0)
        if (r > TRAPR) then
            OBJPOT(i,j) = OBJPOT(i,j)+TRAPHEIGHT
        end if
    end do
    end do
    !$OMP END PARALLEL DO
end subroutine

subroutine add_soft_box_trap
    use params
    implicit none
    integer :: i,j
    double precision :: rx,ry
    !$OMP PARALLEL DO
    do i = -NX/2,NX/2
        do j = -NY/2,NY/2
            rx = (dble(i)*DSPACE)-TXDASH
            ry = (dble(j)*DSPACE)-TYDASH
            OBJPOT(i,j) = OBJPOT(i,j)+MIN(TRAPHEIGHT,TRAPHEIGHT/(1.0d0+EXP(-TRAPBETA*(ABS(rx)-TRAPR)))+&
                                          TRAPHEIGHT/(1.0d0+EXP(-TRAPBETA*(ABS(ry)-TRAPR))))
        end do
    end do
    !$OMP END PARALLEL DO
end subroutine

subroutine add_hard_box_trap
    use params
    implicit none
    integer :: i,j
    double precision :: rx,ry
    !$OMP PARALLEL DO
    do i = -NX/2,NX/2
        do j = -NY/2,NY/2
            rx = (dble(i)*DSPACE)-TXDASH
            ry = (dble(j)*DSPACE)-TYDASH
            if (abs(rx) > TRAPR .OR. abs(ry) > TRAPR) then
                OBJPOT(i,j) = OBJPOT(i,j)+TRAPHEIGHT
            end if
        end do
    end do
    !$OMP END PARALLEL DO
end subroutine

subroutine calc_OBJPOT_obj
    use params
    implicit none
    integer :: i,j
    double precision :: rx,ry
    !$OMP PARALLEL DO
    do i = -NX/2,NX/2
        do j = -NY/2,NY/2
            rx = (dble(i)*DSPACE)-OBJXDASH-(OBJAMP*sin(OBJW*TIME))
            ry = (dble(j)*DSPACE)-OBJYDASH
            OBJPOT(i,j) = OBJHEIGHT*EXP(-(1.0d0/RRX**2.0d0)*(rx**2.0d0) - (1.0d0/RRY**2.0d0)*(ry**2.0d0))
        end do
    end do
    !$OMP END PARALLEL DO
end subroutine

subroutine calc_OBJPOT_pins_square
    use params
    implicit none
    integer :: i,j
    double precision :: rx,ry,rxy
    !$OMP PARALLEL DO
    do i = -NX/2,NX/2
        do j = -NY/2,NY/2
            rx = (dble(i)*DSPACE)-OBJXDASH
            ry = (dble(j)*DSPACE)-OBJYDASH
            rxy = (MODULO(rx,OBJPINSDIST)-(OBJPINSDIST/2.0d0))**2.0d0 + (MODULO(ry,OBJPINSDIST)-(OBJPINSDIST/2.0d0))**2.0d0
            OBJPOT(i,j) = OBJHEIGHT*EXP(-(1.0d0/OBJPINSSIG**2.0d0)*rxy)
        end do
    end do
    !$OMP END PARALLEL DO
end subroutine

subroutine calc_OBJPOT_rot
   use params
   implicit none
   integer :: i,j
   double precision :: rtheta
   double precision, dimension(2,2) :: rotmat
   double precision, dimension(2) :: point,rotpoint
   call calc_new_obj_angle
   rtheta = OBJANGLE
   rotmat(1,1) = cos(rtheta)
   rotmat(2,1) = -sin(rtheta)
   rotmat(1,2) = sin(rtheta)
   rotmat(2,2) = cos(rtheta)
    !$OMP PARALLEL DO
    do i = -NX/2,NX/2
        do j = -NY/2,NY/2
            point(1) = dble(i)*DSPACE
            point(2) = dble(j)*DSPACE
            rotpoint = matmul(rotmat,point)
            OBJPOT(i,j) = OBJHEIGHT*EXP( -(1.0d0/RRX**2.0d0)*(rotpoint(1)-OBJXDASH)**2.0d0&
                            -(1.0d0/RRY**2.0d0)*(rotpoint(2)-OBJYDASH)**2.0d0 )
       end do
   end do
   !$OMP END PARALLEL DO
end subroutine

subroutine calc_OBJPOT_img
    use params
    use bitmap
    implicit none
    integer :: i,j

    CALL load_bmp
    do i = -NX/2,NX/2
        do j = -NY/2,NY/2
            OBJPOT(i,j) = OBJHEIGHT*(Img(i,j)/255.0d0)
        end do
    end do
end subroutine

subroutine calc_OBJPOT_shin
!-Note:This is the shin experiment
    use params
    implicit none
    integer :: i,j
    double precision :: trVelx,trVely
    !Section 1 - Ramping up trap movement
    if(TIME .lt. (TTM/8.0d0)) then
        if (enablePot) then
            call calc_OBJPOT_obj
        end if
        if (enableTrap) then
            trVelx = (TVXDASH/2.0d0)*(tanh((6.0d0*TIME/(TTM*8.0d0))-3.0d0)+1.0d0)
            trVely = (TVYDASH/2.0d0)*(tanh((6.0d0*TIME/(TTM*8.0d0))-3.0d0)+1.0d0)
            TXDASH  = TXDASH  + (trVelx*DBLE(DT))
            TYDASH  = TYDASH  + (trVely*DBLE(DT))
            do i = -NX/2,NX/2
            do j = -NY/2,NY/2
                OBJPOT(i,j) = OBJPOT(i,j)&
                    +0.5d0*((dble(i)*DSPACE+TXDASH)*(dble(i)*DSPACE+TXDASH)&
                    +(dble(j)*DSPACE+TYDASH)*(dble(j)*DSPACE+TYDASH))
            end do
            end do
        end if
    end if
    !Section 2 - trap moving at terminal velocity
    if(TIME .gt. (TTM/8.0d0) .and. TIME .lt.  (7.0d0*TTM/8.0d0)) then
        if (enablePot) then
            call calc_OBJPOT_obj
        end if
        if (enableTrap) then
            TXDASH  = TXDASH  + (TVXDASH*DBLE(DT))
            TYDASH  = TYDASH  + (TVYDASH*DBLE(DT))
            do i = -NX/2,NX/2
            do j = -NY/2,NY/2
                OBJPOT(i,j) = OBJPOT(i,j)&
                    +0.5d0*((dble(i)*DSPACE+TXDASH)*(dble(i)*DSPACE+TXDASH)&
                    +(dble(j)*DSPACE+TYDASH)*(dble(j)*DSPACE+TYDASH))
            end do
            end do
        end if
    end if
    !Section 3 - Ramping down trap movement
    if(TIME .gt. (7.0d0*TTM/8.0d0) .and. TIME .lt. TTM) then
        if (enablePot) then
            call calc_OBJPOT_obj
        end if
        if (enableTrap) then
            trVelx = (TVXDASH/2.0d0)&
                *(tanh((-6.0d0*(TIME-(7.0d0*TTM/8.0d0))/(TTM/8.0d0))+3.0d0)+1.0d0)
            trVely = (TVYDASH/2.0d0)&
                *(tanh((-6.0d0*(TIME-(7.0d0*TTM/8.0d0))/(TTM/8.0d0))+3.0d0)+1.0d0)
            TXDASH  = TXDASH  + (trVelx*DBLE(DT))
            TYDASH  = TYDASH  + (trVely*DBLE(DT))
            do i = -NX/2,NX/2
            do j = -NY/2,NY/2
                OBJPOT(i,j) = OBJPOT(i,j)&
                    +0.5d0*((dble(i)*DSPACE+TXDASH)*(dble(i)*DSPACE+TXDASH)&
                    +(dble(j)*DSPACE+TYDASH)*(dble(j)*DSPACE+TYDASH))
            end do
            end do
        end if
    end if

    !Section 4 - Ramping down laser beam
    if(TIME .gt. TTM) then
        if (enablePot) then
            OBJHEIGHT  = OBJHEIGHT  - ((DBLE(DT)*15*harm_osc_mu)/(2.0*PI*15.0*0.4))
            if(OBJHEIGHT .gt. 0.0d0) then
                call calc_OBJPOT_obj
            end if
            if(OBJHEIGHT .lt. 0.0d0) then
                    OBJPOT = 0.0d0
                    OBJHEIGHT = -1.0d0
                    potRep = .false. !Should stop recalculating potential now
            end if
        end if
        if (enableTrap) then
            do i = -NX/2,NX/2
            do j = -NY/2,NY/2
                OBJPOT(i,j) = OBJPOT(i,j)&
                    +0.5d0*((dble(i)*DSPACE+TXDASH)*(dble(i)*DSPACE+TXDASH)&
                    +(dble(j)*DSPACE+TYDASH)*(dble(j)*DSPACE+TYDASH))
            end do
            end do
        end if
    end if

end subroutine


      SUBROUTINE splin2(x1a,x2a,ya,y2a,m,n,x1,x2,y)
      INTEGER m,n,NN
      REAL x1,x2,y,x1a(m),x2a(n),y2a(m,n),ya(m,n)
      PARAMETER (NN=100)
CU    USES spline,splint
      INTEGER j,k
      REAL y2tmp(NN),ytmp(NN),yytmp(NN)
      do 12 j=1,m
        do 11 k=1,n
          ytmp(k)=ya(j,k)
          y2tmp(k)=y2a(j,k)
11      continue
        call splint(x2a,ytmp,y2tmp,n,x2,yytmp(j))
12    continue
      call spline(x1a,yytmp,m,1.e30,1.e30,y2tmp)
      call splint(x1a,yytmp,y2tmp,m,x1,y)
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/splin2.for


      SUBROUTINE voltra(n,m,t0,h,t,f,g,ak)
      INTEGER m,n,MMAX
      REAL h,t0,f(m,n),t(n),g,ak
      EXTERNAL ak,g
      PARAMETER (MMAX=5)
CU    USES ak,g,lubksb,ludcmp
      INTEGER i,j,k,l,indx(MMAX)
      REAL d,sum,a(MMAX,MMAX),b(MMAX)
      t(1)=t0
      do 11 k=1,m
        f(k,1)=g(k,t(1))
11    continue
      do 16 i=2,n
        t(i)=t(i-1)+h
        do 14 k=1,m
          sum=g(k,t(i))
          do 13 l=1,m
            sum=sum+0.5*h*ak(k,l,t(i),t(1))*f(l,1)
            do 12 j=2,i-1
              sum=sum+h*ak(k,l,t(i),t(j))*f(l,j)
12          continue
            if(k.eq.l)then
              a(k,l)=1.
            else
              a(k,l)=0.
            endif
            a(k,l)=a(k,l)-0.5*h*ak(k,l,t(i),t(i))
13        continue
          b(k)=sum
14      continue
        call ludcmp(a,m,MMAX,indx,d)
        call lubksb(a,m,MMAX,indx,b)
        do 15 k=1,m
          f(k,i)=b(k)
15      continue
16    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/voltra.for


      SUBROUTINE medfit(x,y,ndata,a,b,abdev)
      INTEGER ndata,NMAX,ndatat
      PARAMETER (NMAX=1000)
      REAL a,abdev,b,x(ndata),y(ndata),arr(NMAX),xt(NMAX),yt(NMAX),aa,
     *abdevt
      COMMON /arrays/ xt,yt,arr,aa,abdevt,ndatat
CU    USES rofunc
      INTEGER j
      REAL b1,b2,bb,chisq,del,f,f1,f2,sigb,sx,sxx,sxy,sy,rofunc
      sx=0.
      sy=0.
      sxy=0.
      sxx=0.
      do 11 j=1,ndata
        xt(j)=x(j)
        yt(j)=y(j)
        sx=sx+x(j)
        sy=sy+y(j)
        sxy=sxy+x(j)*y(j)
        sxx=sxx+x(j)**2
11    continue
      ndatat=ndata
      del=ndata*sxx-sx**2
      aa=(sxx*sy-sx*sxy)/del
      bb=(ndata*sxy-sx*sy)/del
      chisq=0.
      do 12 j=1,ndata
        chisq=chisq+(y(j)-(aa+bb*x(j)))**2
12    continue
      sigb=sqrt(chisq/del)
      b1=bb
      f1=rofunc(b1)
      b2=bb+sign(3.*sigb,f1)
      f2=rofunc(b2)
      if(b2.eq.b1)then
        a=aa
        b=bb
        abdev=abdevt/ndata
        return
      endif
1     if(f1*f2.gt.0.)then
        bb=b2+1.6*(b2-b1)
        b1=b2
        f1=f2
        b2=bb
        f2=rofunc(b2)
        goto 1
      endif
      sigb=0.01*sigb
2     if(abs(b2-b1).gt.sigb)then
        bb=b1+0.5*(b2-b1)
        if(bb.eq.b1.or.bb.eq.b2)goto 3
        f=rofunc(bb)
        if(f*f1.ge.0.)then
          f1=f
          b1=bb
        else
          f2=f
          b2=bb
        endif
        goto 2
      endif
3     a=aa
      b=bb
      abdev=abdevt/ndata
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/medfit.for


module global_variables

  !*****************************************************************************************************************
  !
  ! OVERVIEW
  !
  ! Here are defined - cosmological, astronomical, physical, mathematical and numerical constants (precision)
  !                  - the model parameters
  !
  ! G.A.S. uses:     - 1     kpc as lenght scale
  !                  - 1     Gyr as time scale
  !                  - 10^11 Msun as mass scale
  !                  - 1     K    as temperature scale
  !                  - All other units can be deduced from that units
  !
  ! NO SUBROUTINE IN THIS MODULE
  !
  ! NO FUNCTION IN THIS MODULE
  !
  !*****************************************************************************************************************

  public

  integer(kind=4),parameter :: MAXPATHSIZE                     = 512                                                      ! Maximum length of a path/file name
  !
  ! mathematical constants
  real(kind=8),parameter    :: pi                              = 3.141592653589793238d0                                   ! Just pi
  !
  ! physical constants
  real(kind=8),parameter    :: light_speed_mPerSec             = 2.99792458d8                                             ! speed of light (m/s)
  real(kind=8),parameter    :: light_speed_kmPerSec            = 2.99792458d5                                             ! speed of light (km/s)
  real(kind=8),parameter    :: kb                              = 1.380650424d-23                                          ! Boltzmann constant (Joule/K = kg.m^2/s^2/K)
  real(kind=8),parameter    :: mp                              = 1.67262163783d-27                                        ! mass of a proton (kg)
  real(kind=8),parameter    :: sigma_t                         = 6.65245855827d-29                                        ! Thomson cross-section for electron (in m^2)
  ! astronomical constants
  real(kind=8),parameter    :: Z_Sun                           = 0.02d0                                                   ! Solar metallicity (mass fraction)
  real(kind=8),parameter    :: L_Sun                           = 3.842714d26                                              ! Sun's bolometric luminosity (W = Joule/s = kg.m^2/s^3)
  real(kind=8),parameter    :: L_Sun_erg_s                     = L_Sun * 1.d7                                             ! Sun's bolometric luminosity (1 Joule = 1.e7 ergs)
  real(kind=8),parameter    :: M_Sun                           = 1.988550d30                                              ! (kg)
  real(kind=8),parameter    :: gravconst                       = 6.6742867d-11                                            ! Gravitational constant (in m^3/kg/s^2)
  !
  ! units conversions & conversion factor
  real(kind=8),parameter    :: mass_code_unit_in_M_Sun         = 1.d11                                                    ! 1 mass code unit = 10^11 M_sun
  real(kind=8),parameter    :: M_Sun_in_mass_code_unit         = 1.d0/mass_code_unit_in_M_Sun                             ! 1 M_sun in code unit
  real(kind=8),parameter    :: mass_code_unit_in_kg            = 1.d11*M_Sun                                              ! 1 mass code unit (10^11 Msun) in kg (number of kg in 10^11 Msun) (~ 1.989 10^41 kg)
  real(kind=8),parameter    :: kpc_in_m                        = 3.0856776d19                                             ! number of meters in 1 kpc
  real(kind=8),parameter    :: pc_in_cm                        = 3.0856776d18                                             ! number of centimeter in 1 pc
  real(kind=8),parameter    :: kpc_in_cm                       = pc_in_cm*1.d3
  real(kind=8),parameter    :: kpc_in_km                       = kpc_in_m*1.d-3                                           ! number of kilometer in 1 kpc
  real(kind=8),parameter    :: Mpc_in_km                       = kpc_in_m                                                 ! number of kilometer in 1 Mpc
  real(kind=8),parameter    :: Gyr_in_s                        = 3.1556952d16                                             ! number of second in 1 Gyr
  real(kind=8),parameter    :: Gyr_in_yr                       = 1.d9                                                     ! number of yr in 1 Gyr
  real(kind=8),parameter    :: light_speed_code_unit           = light_speed_mPerSec*Gyr_in_s/kpc_in_m                    ! in [kpc/Gyr] (~ 306601)
  real(kind=8),parameter    :: J_in_code_unit                  = Gyr_in_s**2./ mass_code_unit_in_kg/(kpc_in_m**2.)        ! 1 joule in code unit (~ 5.25980 10^-48)
  real(kind=8),parameter    :: E_code_unit_in_J                = 1.d0/J_in_code_unit                                      ! 1 code unit energy (~ 1.90121 10^48 J)
  real(kind=8),parameter    :: L_code_unit_in_W                = mass_code_unit_in_kg*(kpc_in_m)**2./(Gyr_in_s**3.)       ! 1 code unit luminosity [10^11.Msun.kpc^2/Gyr^3] (~ 6.02457 10^30 W)
  real(kind=8),parameter    :: L_Sun_in_code_unit              = L_sun/L_code_unit_in_W                                   ! 1 solar bolometric luminosity in code unit [10^11.Msun.kpc^2/Gyr^3] (~ 6.3822 10^-5)
  real(kind=8),parameter    :: gravconst_code_unit             = gravconst*mass_code_unit_in_kg/kpc_in_m**3.*Gyr_in_s**2. ! Gravitational constant [in code unit] (kpc^3/(10^11 Msun)/Gyr^2) : (~ 4.49862 10^5)
  real(kind=8),parameter    :: vel_code_unit_2_kmPerSec        = kpc_in_km/Gyr_in_s                                       ! from kpc/Gyr --> km/s
  real(kind=8),parameter    :: vel_code_unit_2_mPerSec         = kpc_in_m/Gyr_in_s                                        ! from kpc/Gyr --> m/s
  real(kind=8),parameter    :: mass_rate_code_unit_2_MsunPerYr = mass_code_unit_in_M_Sun/Gyr_in_yr                        ! from 10^11Msun/Gyr --> Msun/yr
  !
  ! cosmological parameters
  real(kind=8)              :: h_0                                        ! [km/s/Mpc]
  real(kind=8)              :: h_0_code_unit                              ! [Gyr]
  real(kind=8)              :: Omega_L                                    ! Dark energy, fixed during initialization (red_cosmology)
  real(kind=8)              :: Omega_m                                    ! Matter, fixed during initialization (red_cosmology)
  real(kind=8)              :: Omega_b                                    ! Baryons, fixed during initialization (red_cosmology)
  real(kind=8)              :: baryon_fraction                            ! Baryonic fraction, fixed during initialization (red_cosmology)
  real(kind=8)              :: rho_crit_code_unit
  !
  ! dm-simulation parameters
  real(kind=8)              :: L_box                                      ! kpc (code unit)
  real(kind=8)              :: M_tot_min                                  ! minimal halo mass used in the halo finder process (= 20 * dm_particle_mass)
  real(kind=8)              :: dm_particle_mass                           ! mass of a dark-matter particle in the N-body simulation (depend of the resolution)
  !                                                                       ! fixed during initialization (IO_read_parameter_file)
  ! model parameters
  !
  real(kind=8)              :: physical_precision                         ! given in input
  !
  ! cleaning process parameters
  integer(kind=4)           :: nb_of_desc_halo_test                       ! If the cleaning process is turn ON,
                                                                          ! The cleaning algorithm checks various properties of halos in the next 'nb_of_desc_halo_test' halos.
  real(kind=4)              :: min_halo_goodness_of_branch                ! goodness minimal value for keep the branch
  real(kind=4)              :: min_dm_goodness_of_branch                  ! goodness minimal value for keep the branch (only dm-properties are check)
  real(kind=8)              :: Ecut                                       ! halo is condidered stable (virialize) if Ek < |Ecut*Ep|
  !
  ! background
  real(kind=8),parameter    :: T_reion                         = 3.d4     ! Valageas & Silk 1999 [K]
  real(kind=8)              :: z_overlap                                  ! The redshift at which the first H II regions begin to overlap (11) = 1. + z_reion
  real(kind=8)              :: z_reion                                    ! The redshift at which most of the medium is re-ionized (10), given in input
  real(kind=8)              :: cold_stream_efficiency                     ! given in input
  real(kind=8)              :: cooling_efficiency                         ! given in input
  real(kind=8)              :: TI_efficiency                              ! given in input
  !
  ! galaxy
  real(kind=8)              :: epsilon_merge                              ! critical mass ratio that separates major and minor mergers
  ! stars
  character(MAXPATHSIZE)    :: IMF                                        ! given in input (kennicutt, scalo, salpeter, TH2, TH4)
  ! disc
  real(kind=8),parameter    :: Q_crit                          = 1.d0     ! without unit  FIXED HERE
  real(kind=8)              :: disc_stripping_efficiency                  ! given in input
  real(kind=8)              :: disc_ejecta_efficiency                     ! given in input
  ! agn
  real(kind=8)              :: agn_ejecta_efficiency                      ! given in input
  real(kind=8)              :: M_BH_min                                   ! given in input
  real(kind=8)              :: agn_gas_coupling                           ! given in input
  !
  ! END model parameters
  !
  ! numerical parameter
  real(kind=8),parameter    :: x_cut                           = 1.d-4    ! radius parameter ratio (used to gas profil integration)
  real(kind=8),parameter    :: num_precision                   = 1.d-8    ! numerical precision
  real(kind=8),parameter    :: num_accuracy                    = 1.d-12   ! numerical accuracy
  !
  ! other global parameters
  real(kind=8)              :: dt_min_use

end module global_variables