      PROGRAM TCM
C==================================================================
C       Modélisation des transferts de chaleur & matière
C       ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
C                         (1°partie)
C
C Modifié le 06.04.97
C==================================================================
C Tableaux : . u      : champ des températures aux noeuds
C            . S      : matrice à inverser (implicite)
C            . s1, s2 : contiennent la décomposition LU de S
C            . g      : second membre du système EF
C
C Scalaires : . L,A       : caractéristiques géométriques du milieu
C             . cond,rhoc : caractéristiques thermiques du milieu
C             . h,Tf      : coefficient de convection et
C                           température du fluide en x=0.
C             . N         : nombre d'éléments finis
C             . ITMAX     : Nbre de pas de temps à effectuer
C                           avec h=h (échauffement)
C             . MUL       : Nbre de pas de temps total = ITMAX*MUL
C             . dx,dt     : Pas spatial et temporel
C             . IDIAG     : =1 -> diagonalisation de C
C             . ISAV      : Nbre de pas de temps entre deux sauv.
C             . NSAV      : Nbre de pas depuis la derniere sauv.
C             . NO        : Numero de la derniere sauvegarde
C==================================================================
C
      IMPLICIT REAL*8(A-H,O-Z)
      REAL*8 L
C
      PARAMETER(NN=1000)
C
      DIMENSION u(NN),S(3,NN),g(NN),s1(NN),s2(NN)
C
C------------------------------------------------------------------
C
C     Initialisation
C     --------------
      WRITE(*,*)'theta [0-1] ? :'
      READ(*,*)theta
      IF(theta.EQ.(0.0D0))THEN
         WRITE(*,*)'Diagonalisation de C (0=non) ? :'
         READ(*,*)IDIAG
      ELSE
         IDIAG=0
      ENDIF
C
C     - matériau
C
      A     = 1.0D0
      L     = 0.1D0
      cond  = 400.0D0
      rhoc  = 8900.0D0 * 384.0D0
C Cu  8900.0D0 * 384.0D0  k = 400
C Fer 7900.0D0 * 447.0D0  k = 70
C Inox 8000.0D0 * 400.0D0 k = 20
C1.0D0/(1.0D0)
C
C     - convection
C
      h     = 1.0D3
      Tf    = 100.0D0
C
C     - intégrateur
C
      N     = 30
      TFIN  = 10.0D0
      MUL   = 4
      ITMAX = 5
      ISAV  = 1
C
C     Calcul du pas spatial et temporel
C     ---------------------------------
      dx = L/DBLE(N)
      dt = TFIN/DBLE(ITMAX)
      eta=cond/rhoc
C
      WRITE(*,*)
      IF(theta.LT.0.5D0)THEN
         dtms=dx*dx/6.0D0/eta/(1-2.*theta)
         WRITE(*,*)'dt max stab  :',dtms
         IF(dt.GT.dtms) THEN
            WRITE(*,*)'   risque d''instabilite !'
            WRITE(*,*)'   ITMAX min =',TFIN/dtms
            WRITE(*,*)'   N max     =',
     #                L/DSQRT(eta*6.0D0*dt*(1-2.*theta))
         ENDIF
      ELSE
         WRITE(*,*)'dt max stab  : infini'
      ENDIF
      IF(theta.LT.1.0D0)THEN
         dtmo=dx*dx/12.0D0/eta/(1-theta)
         WRITE(*,*)'dt max oscil :',dtmo
         IF(dt.GT.dtmo) THEN
            WRITE(*,*)'   risque d''oscillations !'
            WRITE(*,*)'   ITMAX min =',TFIN/dtmo
            WRITE(*,*)'   N max     =',
     #                L/DSQRT(eta*12.0D0*dt*(1-theta))
         ENDIF
      ELSE
         WRITE(*,*)'dt max oscil : infini'
      ENDIF
C
C     Affichage des données à l'écran
C     -------------------------------
      WRITE(*,120)dx,h,cond,dt,Tf,rhoc,cond/rhoc
      WRITE(*,*)'<SPACE>'
      READ(*,*)
C
C     Ouverture ficher resultat
C     -------------------------
      OPEN(UNIT=1,FILE='res.m',STATUS='UNKNOWN')
      WRITE(1,*)'dx=',dx,';L=',L,';N=',N,';'
      WRITE(1,*)'cond=',cond,';rhoc=',rhoc,';'
      WRITE(1,*)'h=',h,';Tf=',Tf,';'
      WRITE(1,*)'dt=',dt,';A=',A,';'
      WRITE(1,*)'theta=',theta,';'
C
C     Calcul de la solution analytique
C     --------------------------------
      dt2=dt
      ITMAX2=ITMAX
      CALL ANA(h,cond,rhoc,N,L,Tf,ITMAX2,dt2,dx,ISAV,MUL,TFIN)
      WRITE(*,130)
C
C     Initialisation des températures
C     -------------------------------
      DO i=1,N+1
         u(i)=0.0D0
      ENDDO
      IEVAL=0
C
C     Calcul de S
C     -----------
      a1 = cond*A/dx
      a2 = rhoc*A*dx/6.0D0
      CALL EVALS(a1,a2,A,theta,S,NN,s1,s2,h,N,dt,IDIAG)
C
C------------------------------------------------------------------
C                    Boucle des pas de temps
C------------------------------------------------------------------
C
      IT   = 0
      NSAV = 0
      NO=0
      DO i=1,N+1
         WRITE(1,*)'u(',i,',',NO+1,')=',u(i),';'
         WRITE(1,*)'t(',NO+1,')=',IT*dt,';'
      ENDDO
C
 10   CONTINUE
      IT=IT+1
      NSAV=NSAV+1
C
C     Calcul de g (second membre)
C     ---------------------------
      CALL EVALG(a1,a2,u,A,Tf,theta,NN,g,h,N,dt,IT,ITMAX,IDIAG,S)
C
      IF((IT.EQ.ITMAX).AND.(IEVAL.EQ.0)) THEN
         IEVAL=1
         h=0.0D0
         CALL EVALS(a1,a2,A,theta,S,NN,s1,s2,h,N,dt,IDIAG)
      ENDIF
C
C     Calcul de u(IT)
C     ---------------
      IF(IDIAG.EQ.0)THEN
         u(1)=g(1)
         DO i=2,N+1
            u(i)=g(i)-s2(i)*u(i-1)
         ENDDO
C
         u(N+1) = u(N+1)/s1(N+1)
         DO i=N,1,-1
            u(i)=(u(i)-S(1,i)*u(i+1))/s1(i)
         ENDDO
      ELSE
         DO i=1,N+1
            u(i)=g(i)/S(2,i)
         ENDDO
      ENDIF
C
C     Sauvegarde vers MATLAB
C     ----------------------
      IF(NSAV.EQ.ISAV) THEN
         NSAV=0
         NO=NO+1
         DO i=1,N+1
            WRITE(1,*)'u(',i,',',NO+1,')=',u(i),';'
            WRITE(1,*)'t(',NO+1,')=',IT*dt,';'
         ENDDO
         WRITE(*,100)IT,IT*dt,u(1)
      ENDIF
C
      IF(IT.NE.ITMAX*MUL-1) GOTO 10
C
C------------------------------------------------------------------
C                         Fin de boucle
C------------------------------------------------------------------
C
C     Fermeture du fichier
C     --------------------
      CLOSE(UNIT=1)
C
      WRITE(*,110)
C
C==================================================================
C
 100  FORMAT(' pas : ',I5,'    temps : ',D10.4, '    T(1) :',D10.4)
 110  FORMAT(/'  Execution teminee !     resultats dans res.m')
 120  FORMAT(/' dx :',D10.4,'   h  :',D10.4,'   k    :',D10.4,
     #       /' dt :',D10.4,'   Tf :',D10.4,'   rhoc :',D10.4,
     #       '   eta :',D10.4,/ )
 130  FORMAT(/' Solution analytique calculee ! --> uan.m'/)
C
      END


module prec
  integer, parameter :: sp = kind(1.0)
  integer, parameter :: dp = kind(1.d0)
end module prec

subroutine fMandelbrot(dat, ext, nx, ny, nmax)
  use prec
  implicit none

  ! arguments
  integer, intent(in)        :: nx, ny, nmax
  real(kind=dp), intent(in)  :: ext(4)
  real(kind=dp), intent(out), dimension(nx, ny) :: dat

  !f2py integer, optional, intent(in) :: nmax = 1000

  ! local variables
  integer          :: i, j, k
  complex(kind=dp) :: z0, z
  real(kind=dp)    :: x, y

  dat = nmax
  !$omp parallel do private(j, x, y, z0, z, k)
  do i=1, nx
    do j=1, ny
      x  = ext(1) + (ext(2) - ext(1)) / (nx - 1.) * (i - 1.)
      y  = ext(3) + (ext(4) - ext(3)) / (ny - 1.) * (j - 1.)
      z0 = dcmplx(x, y)
      z  = (0, 0)

      do k=1, nmax
        if (abs(z) > 2.0) then
          dat(i,j) = k - 1
          exit
        end if
        z = z**2 + z0
      end do
    end do
  end do
  !$omp end parallel do

  return
end subroutine fMandelbrot


! test_tridiag.f90 --
!     Experiment with test-driven development in a numerical
!     context: can we sensibly formulate tests before having
!     the implementation that needs to be tested?
!

! tridiag --
!     Simple module for solving systems of linear equations
!     of the form:
!         a(k) x(k-1)  +  b(k) x(k)  +   c(k) x(k+1)  =  d(k)
!
!     Note:
!     With the original routine (solve_original) all tests
!     fail - as required.
!
!     Note:
!     The subroutines change the arguments b and d
!
module tridiag
    implicit none

contains

subroutine solve_original( a, b, c, d, x )
    real, dimension(:) :: a, b, c, d, x

    x = 0.0 ! Just a stub for now

end subroutine solve_original

subroutine solve( a, b, c, d, x )
    real, dimension(:) :: a, b, c, d, x

    integer :: i
    integer :: n
    real    :: factor

    n = size(a)
    do i = 2,n
        factor = a(i) / b(i-1)
        b(i)   = b(i) - factor * c(i-1)
        d(i)   = d(i) - factor * d(i-1)
    enddo

    x(n) = d(n) / b(n)
    do i = n-1,1,-1
        x(i) = (d(i) - c(i) * x(i+1)) / b(i)
    enddo

end subroutine solve

end module tridiag

! test_tridiag --
!     Module containing all the tests for the tridiag module
!
!     Note: I found the need for the "boundary condition" in test_basic
!     only after checking the results for all tests. All answers were
!     as expected (modulo some truncation errors in the solution for the
!     largest system - test_diagonal_dom3) but this was not the case
!     for test_basic. Without the different value for d in the last
!     row, the solution is completely different than a set of ones.
!
!     This incident shows that it does pay off to formulate these
!     tests on the outset. It forces you to think about tests that
!     may or may not be relevant, but that at least can be used.
!
module test_tridiag
    use ftnunit
    use tridiag

    implicit none

    real, parameter :: margin = 1.0e-6

contains

subroutine test_all

    call test( test_trivial,       "Solve trivial system a=0, b=3, c=0, d=1" )
    call test( test_basic,         "Solve basic system a=0, b=6, c=-5, d=1" )
    call test( test_diagonal_dom1, "Solve diagonally dominant system - n=3")
    call test( test_diagonal_dom2, "Solve diagonally dominant system - n=10")
    call test( test_diagonal_dom3, "Solve diagonally dominant system - n=100")

end subroutine test_all

subroutine test_trivial

    integer, parameter :: rows = 10
    real, dimension(rows) :: a, b, c, d, x, y

    a = 0.0
    b = 3.0 ! Using 3 because of numerical rounding issues
    c = 0.0
    d = 1.0

    y = 1.0/3.0 ! Expected solution

    call solve( a, b, c, d, x )

    call assert_comparable( x, y, margin, "Solution is uniformly 1/3" )

end subroutine test_trivial

subroutine test_basic

    integer, parameter :: rows = 10
    real, dimension(rows) :: a, b, c, d, x, y

    a = 0.0
    b = 6.0
    c = -5.0
    d = 1.0

    d(rows) = 6.0 ! Boundary condition!

    !

    y = 1.0 ! Expected solution

    call solve( a, b, c, d, x )

    call assert_comparable( x, y, margin, "Solution is uniformly 1" )

end subroutine test_basic

subroutine test_diagonal_dom1

    integer, parameter :: rows = 3
    real, dimension(rows) :: a, b, c, d, x, y

    a = -1.0
    b = 2.0
    c = -1.0
    d(1) =              b(1) * 1.0 + c(1) * 1.0
    d(2) = a(2) * 1.0 + b(2) * 1.0 + c(2) * 1.0
    d(3) = a(3) * 1.0 + b(3) * 1.0

    y = 1.0 ! Expected solution

    call solve( a, b, c, d, x )

    call assert_comparable( x, y, margin, "Solution is uniformly 1" )

end subroutine test_diagonal_dom1

subroutine test_diagonal_dom2

    integer, parameter    :: rows = 10
    real, dimension(rows) :: a, b, c, d, x, y
    integer               :: i

    a = -1.0
    b = 2.0
    c = -1.0
    y = (/ (1.0/i ,i=1,rows) /) ! Expected solution

    d(2:rows-1) = a(2:rows-1) * y(1:rows-2) + b(2:rows-1) * y(2:rows-1) + &
                  c(2:rows-1) * y(3:rows)
    d(1)        =                             b(1) * y(1) + c(1) * y(2)
    d(rows)     = a(rows) * y(rows-1)        + b(rows) * y(rows)

    call solve( a, b, c, d, x )

    call assert_comparable( x, y, margin, "Solution is 1/k (10 rows)" )

end subroutine test_diagonal_dom2

subroutine test_diagonal_dom3

    integer, parameter    :: rows = 100
    real, dimension(rows) :: a, b, c, d, x, y
    integer               :: i

    a = -1.0
    b = 2.0
    c = -1.0
    y = (/ (1.0/i ,i=1,rows) /) ! Expected solution

    d(2:rows-1) = a(2:rows-1) * y(1:rows-2) + b(2:rows-1) * y(2:rows-1) + &
                  c(2:rows-1) * y(3:rows)
    d(1)        =                             b(1) * y(1) + c(1) * y(2)
    d(rows)     = a(rows) * y(rows-1)        + b(rows) * y(rows)

    call solve( a, b, c, d, x )

    call assert_comparable( x, y, margin, "Solution is 1/k (100 rows)" )

end subroutine test_diagonal_dom3

end module test_tridiag

! run_tridiag_tests
!     Program to run the tests
!
program run_tridiag_tests
    use ftnunit
    use test_tridiag

    implicit none

    call runtests_init
    call runtests( test_all )
    call runtests_final

end program run_tridiag_tests


Real Function denom(srt, con)
  Parameter (ap1=0.13496, ap2=0.13957, pi=3.1415926, avmass=0.9383)
  Save
  avpi = (ap1+2.*ap2)/3.
  am0 = 1.232
  amn = avmass
  amp = avpi
  amax = srt - avmass
  amin = avmass + avpi
  nmax = 200
  dmass = (amax-amin)/float(nmax)
  sum = 0.
  Do i = 1, nmax + 1
     dm = amin + float(i-1)*dmass
     If (con==1.) Then
        q2 = ((dm**2-amn**2+amp**2)/(2.*dm))**2 - amp**2
        If (q2>0.) Then
           q = sqrt(q2)
        Else
           q = 1.E-06
        End If
        tq = 0.47*(q**3)/(amp**2*(1.+0.6*(q/amp)**2))
     Else If (con==2) Then
        tq = 0.2
        am0 = 1.44
     Else If (con==-1.) Then
        tq = 0.1
        am0 = 1.535
     End If
     a1 = 4.*tq*am0**2/(am0**2*tq**2+(dm**2-am0**2)**2)
     s = srt**2
     p0 = (s+dm**2-amn**2)**2/(4.*s) - dm**2
     If (p0<=0.) Then
        p1 = 1.E-06
     Else
        p1 = sqrt(p0)
     End If
     f = dm*a1*p1
     If ((i==1) .Or. (i==(nmax+1))) Then
        sum = sum + f*0.5
     Else
        sum = sum + f
     End If
  End Do
  denom = sum*dmass/(2.*pi)
  Return
End Function denom


!---------------------------------------------------------------------------------------------------
! All the formulations  have been taken from the original
! article, THERMODYNAMICS PROPERTIES INVOLVING DERIVATIVES using the peng-robinson equation of state
!---------------------------------------------------------------------------------------------------

!--------------------------------------------------------------------------------------------------
! MODULE   peng_robinson
! @routine
! @authors Yu Fang
! @date    07-2017
!--------------------------------------------------------------------------------------------------

MODULE peng_robinson
!
!
       IMPLICIT NONE
!
! CONSTANTS for CO2

       REAL,PARAMETER,PRIVATE :: R_u   =  8.31445d0
       REAL,PARAMETER,PRIVATE :: T_c   =  304.1282d0
       REAL,PARAMETER,PRIVATE :: P_c   =  7377300.0d0
       REAL,PARAMETER,PRIVATE :: omega =  0.228d0
       REAL,PARAMETER,PRIVATE :: m_m   =  0.044d0
       REAL,PARAMETER,PRIVATE :: gam   =  1.3d0       !1.4?
       REAL,PRIVATE :: m     =  0.37464d0 + 1.54226d0*omega - 0.26992d0*omega*omega
       REAL,PRIVATE :: a_c   =  0.45723553d0*R_u*R_u*T_c*T_c/P_c
       REAL,PRIVATE :: b     =  0.077796074d0*R_u*T_c/P_c

!
!
       PUBLIC :: pressure_pr, interenergy_pr, soundspeed_pr

!
       CONTAINS

!
!
!===============================================================================================
       SUBROUTINE pressure_pr(T,v,p)  !Pa
!===============================================================================================
        IMPLICIT NONE
!
        REAL(8) :: T, v, a
        REAL(8) :: p
!LOCAL
!
        REAL(8) :: v_mol
!
!
        v_mol = m_m*v
        a = a_c * ( 1.d0 + m * (1d0 - sqrt(T/T_c)) )
!
        p = R_u*T/(v_mol-b) - a/( v_mol*(v_mol+b) + b*(v_mol-b) )
!
!
       END SUBROUTINE pressure_pr

!===============================================================================================
       SUBROUTINE interenergy_pr(T,v,e)  !J/kg
!===============================================================================================
        IMPLICIT NONE
!
!IN/OUT
        REAL(8) :: T,v,a
        REAL(8) :: e
!LOCAL
        REAL(8) :: v_mol,u0,ui,a_div1, z, BB,p
!
!
       u0 = R_u/( m_m *(gam-1.d0) ) * T
!
       v_mol = m_m*v
       a = a_c * ( 1.d0 + m * (1d0 - sqrt(T/T_c)) )

       CALL pressure_pr(T,v,p)

       z = p*v_mol/(R_u*T)
       BB = b*p/(R_u*T)
       a_div1 = -a_c*m*0.5d0*sqrt(1.d0/(T_c*T))
!
       ui = (T*a_div1 - a)/(b*sqrt(8.0d0)) * log(( z + BB*(1.d0+sqrt(2.d0)) )/ &
&                                           ( z + BB*(1.d0-sqrt(2.d0)) ))
!unit from J/mol --> J/kg
       ui = ui/m_m

       e = u0 + ui
       END SUBROUTINE interenergy_pr

!===============================================================================================
       SUBROUTINE heatcap_v_pr(T,v,cv)  !J/(kg.K)
!===============================================================================================
        IMPLICIT NONE
!
!IN/OUT
        REAL(8) :: T,v,a
        REAL(8) :: cv
!LOCAL
        REAL(8) :: v_mol,cv0,cvi,a_div2, z, BB,p
!
!
       cv0 = R_u/( m_m *(gam-1.d0) )
!
       v_mol = m_m*v
       a = a_c * ( 1.d0 + m * (1d0 - sqrt(T/T_c)) )

       CALL pressure_pr(T,v,p)

       z = p*v_mol/(R_u*T)
       BB = b*p/(R_u*T)
       a_div2 = a_c*m*0.25d0*sqrt(1.d0/(T_c*T*T*T))
!
       cvi = (T*a_div2)/(b*sqrt(8.0d0)) * log(( z + BB*(1.d0+sqrt(2.d0)) )/ &
&                                           ( z + BB*(1.d0-sqrt(2.d0)) ))
!unit from J/mol --> J/kg
       cvi = cvi/m_m

       cv = cv0 + cvi
       END SUBROUTINE heatcap_v_pr

!===============================================================================================
       SUBROUTINE heatcap_p_pr(T,v,cp)  !J/(kg.K)
!===============================================================================================
        IMPLICIT NONE
!
!IN/OUT
        REAL(8) :: T,v,a
        REAL(8) :: cp
!LOCAL
        REAL(8) :: v_mol,cv0,cp0,cvi,cpi,a_div1,a_div2, z, BB,p,AA
!
        REAL(8) :: dp_dT, dv_dT, dz_dT, dAA_dT, dBB_dT
!
       cv0 = R_u/( m_m *(gam-1.d0) )
       cp0 = cv0*gam
!
       v_mol = m_m*v
       a = a_c * ( 1.d0 + m * (1d0 - sqrt(T/T_c)) )

       CALL pressure_pr(T,v,p)

       z = p*v_mol/(R_u*T)
       AA = a*p / (R_u*T*T*R_u)
       BB = b*p/(R_u*T)
       a_div1 = -a_c*m*0.5d0*sqrt(1.d0/(T_c*T))
       a_div2 = a_c*m*0.25d0*sqrt(1.d0/(T_c*T*T*T))
!
       cvi = (T*a_div2)/(b*sqrt(8.0d0)) * log(( z + BB*(1.d0+sqrt(2.d0)) )/ &
&                                           ( z + BB*(1.d0-sqrt(2.d0)) ))
!
       dAA_dT = p/(R_u*R_u*T*T) * (a_div1 - 2.0d0*a/T)
       dBB_dT = -b*p / (R_u*T*T)
!
       dz_dT = dAA_dT*(BB-z) + dBB_dT*(6.0*BB*z+2.0*z-3.0*BB*BB-2.0*BB+AA-z*z)/&
&              (3.0*z*z+2.0*(BB-1.0)*z+(AA-2.0*BB-3.0*BB*BB))

       dp_dT = R_u/(v_mol-b) - a_div1/(v_mol*(v_mol+b) + b*(v_mol-b))
       dv_dT = R_u/p * ( T*dz_dT + z )
!
       cpi = cvi + T*dp_dT*dv_dT - R_u
       cpi = cpi/ m_m
!
       cp = cp0 + cpi
!
!
       END SUBROUTINE heatcap_p_pr

!===============================================================================================
       SUBROUTINE soundspeed_pr(T,v,c)  !m/s
!===============================================================================================
        IMPLICIT NONE
!
!IN/OUT
        REAL(8) :: T,v,a
        REAL(8) :: c
!LOCAL
         REAL(8) :: v_mol,cp,cv,dp_dv,c2
!
       v_mol = m_m*v
       a = a_c * ( 1.d0 + m * (1d0 - sqrt(T/T_c)) )
!
       dp_dv = -R_u*T/((v_mol-b)*(v_mol-b)) + 2.0*a*(v_mol+b)/&
&             ( (v_mol*(v_mol+b)+b*(v_mol-b)) * (v_mol*(v_mol+b)+b*(v_mol-b)) )
!
      CALL heatcap_v_pr(T,v,cv)
      CALL heatcap_p_pr(T,v,cp)
!
      c2 = -v_mol*v_mol*cp/cv*dp_dv
!convert unit
      c = sqrt(c2/m_m)
!
       END SUBROUTINE soundspeed_pr

END MODULE peng_robinson


      SUBROUTINE MB04TW( UPDATQ, M, N, NRE, NCE, IFIRE, IFICE, IFICA, A,
     $                   LDA, E, LDE, Q, LDQ )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To reduce a submatrix E(k) of E to upper triangular form by row
C     Givens rotations only.
C     Here E(k) = E(IFIRE:me,IFICE:ne), where me = IFIRE - 1 + NRE,
C                                             ne = IFICE - 1 + NCE.
C     Matrix E(k) is assumed to have full column rank on entry. Hence,
C     no pivoting is done during the reduction process. See Algorithm
C     2.3.1 and Remark 2.3.4 in [1].
C     The constructed row transformations are also applied to matrix
C     A(k) = A(IFIRE:me,IFICA:N).
C     Note that in A(k) rows are transformed with the same row indices
C     as in E but with column indices different from those in E.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     UPDATQ  LOGICAL
C             Indicates whether the user wishes to accumulate in a
C             matrix Q the orthogonal row transformations, as follows:
C             = .FALSE.: Do not form Q;
C             = .TRUE.:  The given matrix Q is updated by the orthogonal
C                        row transformations used in the reduction.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             Number of rows of A and E.  M >= 0.
C
C     N       (input) INTEGER
C             Number of columns of A and E.  N >= 0.
C
C     NRE     (input) INTEGER
C             Number of rows in E to be transformed.  0 <= NRE <= M.
C
C     NCE     (input) INTEGER
C             Number of columns in E to be transformed.  0 <= NCE <= N.
C
C     IFIRE   (input) INTEGER
C             Index of first row in E to be transformed.
C
C     IFICE   (input) INTEGER
C             Index of first column in E to be transformed.
C
C     IFICA   (input) INTEGER
C             Index of first column in A to be transformed.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, this array contains the submatrix A(k).
C             On exit, it contains the transformed matrix A(k).
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,M).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, this array contains the submatrix E(k) of full
C             column rank to be reduced to upper triangular form.
C             On exit, it contains the transformed matrix E.
C
C     LDE     INTEGER
C             The leading dimension of array E.  LDE >= MAX(1,M).
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,*)
C             On entry, if UPDATQ = .TRUE., then the leading M-by-M
C             part of this array must contain a given matrix Q (e.g.
C             from a previous call to another SLICOT routine), and on
C             exit, the leading M-by-M part of this array contains the
C             product of the input matrix Q and the row transformation
C             matrix that has transformed the rows of the matrices A
C             and E.
C             If UPDATQ = .FALSE., the array Q is not referenced and
C             can be supplied as a dummy array (i.e. set parameter
C             LDQ = 1 and declare this array to be Q(1,1) in the calling
C             program).
C
C     LDQ     INTEGER
C             The leading dimension of array Q. If UPDATQ = .TRUE.,
C             LDQ >= MAX(1,M); if UPDATQ = .FALSE., LDQ >= 1.
C
C     REFERENCES
C
C     [1] Beelen, Th.
C         New Algorithms for Computing the Kronecker structure of a
C         Pencil with Applications to Systems and Control Theory.
C         Ph.D.Thesis, Eindhoven University of Technology,
C         The Netherlands, 1987.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is backward stable.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997.
C     Supersedes Release 2.0 routine MB04FW by Th.G.J. Beelen,
C     Philips Glass Eindhoven, Holland.
C
C     REVISIONS
C
C     June 13, 1997. V. Sima.
C     December 30, 1997. A. Varga: Corrected column range to apply
C                                  transformations on the matrix E.
C
C     KEYWORDS
C
C     Generalized eigenvalue problem, orthogonal transformation,
C     staircase form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      LOGICAL           UPDATQ
      INTEGER           IFICA, IFICE, IFIRE, LDA, LDE, LDQ, M, N, NCE,
     $                  NRE
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), E(LDE,*), Q(LDQ,*)
C     .. Local Scalars ..
      INTEGER           I, IPVT, J
      DOUBLE PRECISION  SC, SS
C     .. External Subroutines ..
      EXTERNAL          DROT, DROTG
C     .. Executable Statements ..
C
      IF ( M.LE.0 .OR. N.LE.0 .OR. NRE.LE.0 .OR. NCE.LE.0 )
     $   RETURN
C
      IPVT = IFIRE - 1
C
      DO 40 J = IFICE, IFICE + NCE - 1
         IPVT = IPVT + 1
C
         DO 20 I = IPVT + 1, IFIRE + NRE - 1
C
C           Determine the Givens transformation on rows i and ipvt
C           to annihilate E(i,j).
C           Apply the transformation to these rows (in whole E-matrix)
C           from columns j up to n .
C           Apply the transformations also to the A-matrix
C           (from columns ifica up to n).
C           Update the row transformation matrix Q, if needed.
C
            CALL DROTG( E(IPVT,J), E(I,J), SC, SS )
            CALL DROT( N-J, E(IPVT,J+1), LDE, E(I,J+1), LDE, SC, SS )
            E(I,J) = ZERO
            CALL DROT( N-IFICA+1, A(IPVT,IFICA), LDA, A(I,IFICA), LDA,
     $                 SC, SS )
            IF( UPDATQ )
     $         CALL DROT( M, Q(1,IPVT), 1, Q(1,I), 1, SC, SS )
   20    CONTINUE
C
   40 CONTINUE
C
      RETURN
C *** Last line of MB04TW ***
      END


program findqmesh

implicit none
  integer, parameter :: DP = kind(1.0d0)
  integer, parameter :: DPC = kind((1.0d0,1.0d0))
integer :: n1,n2,i,m1,m2,mm,mden,p,q,nx1,nx2,mx1,mx2,my1,my2
integer :: components(3),qkv(3)
real(DP) :: xm1,xm2,scqx,scqy,ucqx,ucqy
real(DP) :: qpt(3)
real(DP), parameter :: TOL_Small = 1.0d-6

  open(14,file='qlist',status='replace')
  open(15,file='qlistshift',status='replace')
read(*,*) p, q, n1,n2,m1,m2,scqx,scqy
  mm = n1*m2 - n2*m1
if(mm .lt. 0) then
  mm = -mm
endif
mden = mm*(p)-1
ucqx = (m2*scqx-n2*scqy)/mm
ucqy = (-m1*scqx+n1*scqy)/mm
write(*,*)ucqx,ucqy
i=0
mx1=MAX(i,n1 ,n2 ,n1+n2)
mx2=MAX(i,m1 ,m2 ,m1+m2)
my1=MIN(i,n1 ,n2 ,n1+n2)
my2=MIN(i,m1 ,m2 ,m1+m2)
qpt(3) = 0.0d0
do nx1 = my1*p, mx1*p-1
 do nx2 = my2*q,mx2*q-1
 xm1 = (m2*(1.0d0*nx1/p) - n2*(1.0d0*nx2/q))/mm
 xm2 =(-m1*(1.0d0*nx1/p) + n1*(1.0d0*nx2/q))/mm
  if(xm1 .gt. -0.000000001d0 .and. xm2 .gt. -0.000000001d0)then
   if(xm1 .le. 0.999999999d0 .and. xm2 .le. 0.999999999d0)then
    qpt(1) = xm1
    qpt(2) = xm2
    write(14,'(3(f13.9))') qpt(:)
    qpt(1) = xm1+ucqx
    qpt(2) = xm2+ucqy
    write(15,'(3(f13.9))') qpt(:)
   endif
  endif
 enddo
enddo
  close(14)
  close(15)
end program findqmesh


      SUBROUTINE ks2d2s(x1,y1,n1,x2,y2,n2,d,prob)
      INTEGER n1,n2
      REAL d,prob,x1(n1),x2(n2),y1(n1),y2(n2)
CU    USES pearsn,probks,quadct
      INTEGER j
      REAL d1,d2,dum,dumm,fa,fb,fc,fd,ga,gb,gc,gd,r1,r2,rr,sqen,probks
      d1=0.0
      do 11 j=1,n1
        call quadct(x1(j),y1(j),x1,y1,n1,fa,fb,fc,fd)
        call quadct(x1(j),y1(j),x2,y2,n2,ga,gb,gc,gd)
        d1=max(d1,abs(fa-ga),abs(fb-gb),abs(fc-gc),abs(fd-gd))
11    continue
      d2=0.0
      do 12 j=1,n2
        call quadct(x2(j),y2(j),x1,y1,n1,fa,fb,fc,fd)
        call quadct(x2(j),y2(j),x2,y2,n2,ga,gb,gc,gd)
        d2=max(d2,abs(fa-ga),abs(fb-gb),abs(fc-gc),abs(fd-gd))
12    continue
      d=0.5*(d1+d2)
      sqen=sqrt(float(n1)*float(n2)/float(n1+n2))
      call pearsn(x1,y1,n1,r1,dum,dumm)
      call pearsn(x2,y2,n2,r2,dum,dumm)
      rr=sqrt(1.0-0.5*(r1**2+r2**2))
      prob=probks(d*sqen/(1.0+rr*(0.25-0.75/sqen)))
      return
      END

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


      SUBROUTINE BAL2T4
C
C CHANGE RECORD
C  SUBROUTINE ADDED FOR 2 TIME-LEVEL BALANCES INCLUDING SED,SND,TOX
C **  SUBROUTINES CALBAL CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C **  AND ENERGY BALANCES
C
      USE GLOBAL
	IMPLICIT NONE
	INTEGER::L,LN,K
	REAL::DUTMP,DVTMP
      IF(ISDYNSTP.EQ.0)THEN
        DELT=DT
      ELSE
        DELT=DTDYN
      END IF
C
C **  CALCULATE MOMENTUM AND ENERGY DISSIPATION
C
      DO L=2,LA
        LN=LNC(L)
        UUEOUT=UUEOUT+0.5*DELT*SPB(L)*DXYP(L)*(U(L,1)*TBX(L)
     &      +U(LEAST(L),1)*TBX(LEAST(L))-U(L,KC)*TSX(L)-U(LEAST(L),KC)*TSX(LEAST(L)))
        VVEOUT=VVEOUT+0.5*DELT*SPB(L)*DXYP(L)*(V(L,1)*TBY(L)
     &      +V(LN,1)*TBX(LN)-V(L,KC)*TSY(L)-V(LN,KC)*TSX(LN))
      ENDDO
      DO K=1,KS
        DO L=2,LA
          LN=LNC(L)
          DUTMP=0.5*( U(L,K+1)+U(LEAST(L),K+1)-U(L,K)-U(LEAST(L),K) )
          DVTMP=0.5*( V(L,K+1)+V(LN,K+1)-V(L,K)-V(LN,K) )
          UUEOUT=UUEOUT+DELT*SPB(L)*2.0*DXYP(L)*AV(L,K)
     &        *( DUTMP*DUTMP )/(DZC(K+1)+DZC(K))
          VVEOUT=VVEOUT+DELT*SPB(L)*2.0*DXYP(L)*AV(L,K)
     &        *( DVTMP*DVTMP )/(DZC(K+1)+DZC(K))
          BBEOUT=BBEOUT+DELT*SCB(L)*DXYP(L)*HP(L)
     &        *GP*AB(L,K)*(B(L,K+1)-B(L,K))
        ENDDO
      ENDDO
      RETURN
      END


PROGRAM ZIGZAG

  IMPLICIT NONE
    INTEGER, PARAMETER :: size = 5
    INTEGER :: zzarray(size,size), x(size*size), y(size*size), i, j

    ! index arrays
    x = (/ ((j, i = 1, size), j = 1, size) /)
    y = (/ ((i, i = 1, size), j = 1, size) /)

    ! Sort indices
    DO i = 2, size*size
       j = i - 1
       DO WHILE (j>=1 .AND. (x(j)+y(j)) > (x(i)+y(i)))
          j = j - 1
       END DO
       x(j+1:i) = cshift(x(j+1:i),-1)
       y(j+1:i) = cshift(y(j+1:i),-1)
    END DO

    ! Create zig zag array
    DO i = 1, size*size
       IF (MOD(x(i)+y(i), 2) == 0) THEN
          zzarray(x(i),y(i)) = i - 1
       ELSE
          zzarray(y(i),x(i)) = i - 1
       END IF
    END DO

    ! Print zig zag array
    DO j = 1, size
       DO i = 1, size
          WRITE(*, "(I5)", ADVANCE="NO") zzarray(i,j)
       END DO
       WRITE(*,*)
    END DO

 END PROGRAM ZIGZAG


program mainDipole
    use dipole_mod
    implicit none

    real(8), parameter :: PI = 4d0 * atan(1d0)
    complex(8), parameter :: IU = (0d0, 1d0)

    real(8), parameter :: k0 = 0.5d0                  ! free-space wavenumber [1/m]

    real(8), parameter :: src(3) = [0d0, 0d0, 5d0]    ! dipole position [x', y', z'] in [m], z>=0
    real(8), parameter :: pol(3) = [1d0, 1d0, 1d0]   ! dipole orientation and magnitude [dx, dy, dz]
    real(8), parameter :: ep1_r = 3d0                 ! relative permittivity of upper half-space
    complex(8), parameter :: ep2_r = 4d0              ! relative permittivity of lower half-space, Im(eps2)>=0
    real(8), parameter :: k1 = k0*sqrt(ep1_r)         ! upper half-space wavenumber [1/m]
    logical, parameter :: total_field = .false.        ! .true. to compute total field
                                                      ! .false. to compute scattered field only
    real(8) :: xyz_list(4, 3)  ! list of observation points

    complex(8), allocatable :: Efield(:, :) ! total electric field in [V/m]
    integer :: n

    ! List of observation points
    xyz_list(1, :) = [-9d0, 13d0, 2d0]
    xyz_list(2, :) = [-3.6d0, -4d0, 9d0]
    xyz_list(3, :) = [5d0, -0.2d0, 5.4d0]
    xyz_list(4, :) = [0.6d0, 0.2d0, 10d0]

    ! Compute electric field
    call halfspace_dipole_field(xyz_list, k0, k1, ep1_r, ep2_r, src, pol, Efield, total_field)

    print *, "Efield [Ex, Ey, Ez]"
    do n = 1, size(xyz_list, 1)
        print *, Efield(n, :)
    end do

end program


module day02
implicit none

contains
  subroutine run_intcode(n, intcode)
    integer, intent(in) :: n
    integer, intent(inout) :: intcode(0:n-1)  ! 1D array with index starting as 0
    integer :: opcode, i0, i1, i2, i3

    do i0 = 0, n, 4
      opcode = intcode(i0)

      if (opcode == 99) exit

      ! Indices to fetch values from
      i1 = intcode(i0 + 1)
      i2 = intcode(i0 + 2)
      i3 = intcode(i0 + 3)

      ! Mutate intcode based on opcode
      if(opcode == 1) then
        intcode(i3) = intcode(i1) + intcode(i2)
      else if (opcode == 2) then
        intcode(i3) = intcode(i1) * intcode(i2)
      else
        stop "Illegal opcode!"
      end if
    end do

    ! print *, "End of intcode program"

  end subroutine
end module


!===============================================================================
function pressure(depth) result(press)

! !DESCRIPTION:
!  This function computes pressure in bars from depth in meters
!  using a mean density derived from depth-dependent global
!  average temperatures and salinities from Levitus 1994, and
!  integrating using hydrostatic balance.
!
!  References:
!
!     Levitus, S., R. Burgett, and T.P. Boyer, World Ocean Atlas
!          1994, Volume 3: Salinity, NOAA Atlas NESDIS 3, US Dept. of
!          Commerce, 1994.
!
!     Levitus, S. and T.P. Boyer, World Ocean Atlas 1994,
!          Volume 4: Temperature, NOAA Atlas NESDIS 4, US Dept. of
!          Commerce, 1994.
!
!     Dukowicz, J. K., 2000: Reduction of Pressure and Pressure
!          Gradient Errors in Ocean Simulations, J. Phys. Oceanogr.,
!          submitted.
!
! !REVISION HISTORY:
!  same as module

! !INPUT PARAMETERS:

real, intent(in) :: depth    ! depth in meters

! !OUTPUT PARAMETERS:

real :: press   ! pressure [bars]

! !LOCAL PARAMETERS:
!  adjustment from original code which was written as 0.1_r8
!  which the compiler disliked so constants are now pre-defined here
double precision, parameter ::              &
   pc1 = 0.059808,   &
   pc2 = 0.025,      &
   pc3 = 0.100766,   &
   pc4 = 2.28405e-7, &
   c1  = 1.0
!EOP
!BOC
!-----------------------------------------------------------------------
!  convert depth in meters to pressure in bars
!-----------------------------------------------------------------------

press = pc1*(exp(-pc2*depth) - c1) + pc3*depth + pc4*depth**2

!return

end function pressure
!===============================================================================

!===============================================================================
subroutine state(S_orig, T, P_orig, RHO)

!  ADJUSTED/SLIMMED DOWN FROM state_mod.F90 June 2016

! !DESCRIPTION:
!  Returns the density of water at level k from equation of state
!  $\rho = \rho(d,\theta,S)$ where $d$ is depth, $\theta$ is
!  potential temperature, and $S$ is salinity. the density can be
!  returned as a perturbation (RHOOUT) or as the full density
!  (RHOFULL). Note that only the polynomial EOS choice will return
!  a perturbation density; in other cases the full density is returned
!  regardless of which argument is requested.
!
!  This routine also computes derivatives of density with respect
!  to temperature and salinity at level k from equation of state
!  if requested (ie the optional arguments are present).
!
!  If $k = kk$ are equal the density for level k is returned.
!  If $k \neq kk$ the density returned is that for a parcel
!  adiabatically displaced from level k to level kk.
!
! !REVISION HISTORY:
!  same as module

double precision, parameter :: rho0=4.1/3.996*1000

! !INPUT PARAMETERS:

double precision, intent(in) :: &
  T,               &! pot. temperature at level k  [degC]
  S_orig,          &! salinity at level k         [kg/kg]
  P_orig            ! pressure at reference level   [bar]

! !OUTPUT PARAMETERS:

double precision, intent(out) :: &
  RHO               ! density of water [kg m^-3]

!-----------------------------------------------------------------------
!  local variables:
!-----------------------------------------------------------------------

double precision :: &
  S,                &! [PSU]
  P,                &! [dbar]
  SQR,DENOMK,       &! work arrays
  WORK1, WORK2, T2

double precision, parameter :: &
  c10   = 1.0E01,              &
  c1000 = 1.0E03

!-----------------------------------------------------------------------
!  first check for valid range if requested
!-----------------------------------------------------------------------

! THIS IS SKIPPED HERE

!-----------------------------------------------------------------------
!  MWJF EOS coefficients
!-----------------------------------------------------------------------

!*** these constants will be used to construct the numerator

double precision, parameter ::   &
  mwjfnp0s0t0 =   9.99843699e+2, &
  mwjfnp0s0t1 =   7.35212840e+0, &
  mwjfnp0s0t2 =  -5.45928211e-2, &
  mwjfnp0s0t3 =   3.98476704e-4, &
  mwjfnp0s1t0 =   2.96938239e+0, &
  mwjfnp0s1t1 =  -7.23268813e-3, &
  mwjfnp0s2t0 =   2.12382341e-3, &
  mwjfnp1s0t0 =   1.04004591e-2, &
  mwjfnp1s0t2 =   1.03970529e-7, &
  mwjfnp1s1t0 =   5.18761880e-6, &
  mwjfnp2s0t0 =  -3.24041825e-8, &
  mwjfnp2s0t2 =  -1.23869360e-11

!*** these constants will be used to construct the denominator

double precision, parameter ::    &
  mwjfdp0s0t0 =   1.0e+0,         &
  mwjfdp0s0t1 =   7.28606739e-3,  &
  mwjfdp0s0t2 =  -4.60835542e-5,  &
  mwjfdp0s0t3 =   3.68390573e-7,  &
  mwjfdp0s0t4 =   1.80809186e-10, &
  mwjfdp0s1t0 =   2.14691708e-3,  &
  mwjfdp0s1t1 =  -9.27062484e-6,  &
  mwjfdp0s1t3 =  -1.78343643e-10, &
  mwjfdp0sqt0 =   4.76534122e-6,  &
  mwjfdp0sqt2 =   1.63410736e-9,  &
  mwjfdp1s0t0 =   5.30848875e-6,  &
  mwjfdp2s0t3 =  -3.03175128e-16, &
  mwjfdp3s0t1 =  -1.27934137e-17

!*** MWJF numerator coefficients including pressure

double precision ::&
  mwjfnums0t0, mwjfnums0t1, mwjfnums0t2, mwjfnums0t3,                          &
  mwjfnums1t0, mwjfnums1t1, mwjfnums2t0,                                       &
  mwjfdens0t0, mwjfdens0t1, mwjfdens0t2, mwjfdens0t3, mwjfdens0t4,             &
  mwjfdens1t0, mwjfdens1t1, mwjfdens1t3,                                       &
  mwjfdensqt0, mwjfdensqt2
!-----------------------------------------------------------------------
!  McDougall, Wright, Jackett, and Feistel EOS
!  test value : rho = 1.033213242 for
!  S = 35.0 PSU, theta = 20.0, pressz = 200.0
!
!  from paper:
!  [ (PSU, degC, dbar) -> kg m^-3 ]
!  (35, 25, 2000) -> 1031.654 229
!  ( 0, 20, 1000) -> 1017.726 743
!  (40, 12, 8000) -> 1062.928 258
!-----------------------------------------------------------------------

!   unit conversion
P   = c10*P_orig   ! [bar] -> [dbar]
S   = c1000*S_orig ! [kg/kg] -> [PSU]
SQR = sqrt(S)      ! square root

!      write (*,*) 'S =', S, 'PSU'
!      write (*,*) 'T =', T, 'degC'
!      write (*,*) 'P =', P, 'dbar'

!*** first calculate numerator of MWJF density [P_1(S,T,p)]
mwjfnums0t0 = mwjfnp0s0t0 + P*(mwjfnp1s0t0 + P*mwjfnp2s0t0)
mwjfnums0t1 = mwjfnp0s0t1
mwjfnums0t2 = mwjfnp0s0t2 + P*(mwjfnp1s0t2 + P*mwjfnp2s0t2)
mwjfnums0t3 = mwjfnp0s0t3
mwjfnums1t0 = mwjfnp0s1t0 + P*mwjfnp1s1t0
mwjfnums1t1 = mwjfnp0s1t1
mwjfnums2t0 = mwjfnp0s2t0

WORK1 = mwjfnums0t0 + T * (mwjfnums0t1 + T * (mwjfnums0t2 +                    &
        mwjfnums0t3 * T)) + S * (mwjfnums1t0 +                                 &
        mwjfnums1t1 * T + mwjfnums2t0 * S)

!*** now calculate denominator of MWJF density [P_2(S,T,p)]
mwjfdens0t0 = mwjfdp0s0t0 + P*mwjfdp1s0t0
mwjfdens0t1 = mwjfdp0s0t1 + P**3 * mwjfdp3s0t1
mwjfdens0t2 = mwjfdp0s0t2
mwjfdens0t3 = mwjfdp0s0t3 + P**2 * mwjfdp2s0t3
mwjfdens0t4 = mwjfdp0s0t4
mwjfdens1t0 = mwjfdp0s1t0
mwjfdens1t1 = mwjfdp0s1t1
mwjfdens1t3 = mwjfdp0s1t3
mwjfdensqt0 = mwjfdp0sqt0
mwjfdensqt2 = mwjfdp0sqt2

WORK2 = mwjfdens0t0 + T * (mwjfdens0t1 + T * (mwjfdens0t2 +                    &
        T   * (mwjfdens0t3 + mwjfdens0t4 * T))) +                              &
        S   * (mwjfdens1t0 + T * (mwjfdens1t1 + T*T*mwjfdens1t3)+              &
        SQR * (mwjfdensqt0 + T*T*mwjfdensqt2))

RHO   = WORK1/WORK2-rho0

! SKIPPED RHOFULL, DRHODT, DRHODS CALCULATIONS HERE
! SKIPPED OTHER EOS FUNCTIONS

end subroutine state
!===============================================================================

subroutine hydrostatic_pressure(g,dz,RHO,SSH,HSP)
implicit none
!
!  calculate hydrostatic pressure with in-situ density
!
integer                                     :: k
integer, parameter                          :: imt=3600, jmt=2400, km=42
double precision,               intent(in)  :: g
real,    dimension(km),         intent(in)  :: dz
real,    dimension(imt,jmt,km), intent(in)  :: RHO
real,    dimension(imt,jmt),    intent(in)  :: SSH
real,    dimension(imt,jmt,km), intent(out) :: HSP
real,    parameter                          :: p5 = 0.5

do k=1,km
  if (k==1) then
    HSP(:,:,k) = g*(RHO(:,:,k)*1.0E3)*(dz(k)/2.0 + SSH(:,:)*1.0E-02)
  else
    HSP(:,:,k) = HSP(:,:,k-1) + p5*g*((RHO(:,:,k-1)+RHO(:,:,k))*1.0E03)&
                                 *(dz(k-1)+dz(k))/2.0
  endif
enddo !k
end subroutine hydrostatic_pressure


      SUBROUTINE QSIMP(FUNC,A,B,S)
      PARAMETER (EPS=1.E-6, JMAX=20)
      OST=-1.E30
      OS= -1.E30
      DO 11 J=1,JMAX
        CALL TRAPZD(FUNC,A,B,ST,J)
        S=(4.*ST-OST)/3.
        IF (ABS(S-OS).LT.EPS*ABS(OS)) RETURN
        OS=S
        OST=ST
11    CONTINUE
      PAUSE 'Too many steps.'
      END


      SUBROUTINE slEULR (ORDER, PHI, THETA, PSI, RMAT)
*+
*     - - - - - -
*      E U L R
*     - - - - - -
*
*  Form a rotation matrix from the Euler angles - three successive
*  rotations about specified Cartesian axes (single precision)
*
*  Given:
*    ORDER  c*(*)    specifies about which axes the rotations occur
*    PHI    r        1st rotation (radians)
*    THETA  r        2nd rotation (   "   )
*    PSI    r        3rd rotation (   "   )
*
*  Returned:
*    RMAT   r(3,3)   rotation matrix
*
*  A rotation is positive when the reference frame rotates
*  anticlockwise as seen looking towards the origin from the
*  positive region of the specified axis.
*
*  The characters of ORDER define which axes the three successive
*  rotations are about.  A typical value is 'ZXZ', indicating that
*  RMAT is to become the direction cosine matrix corresponding to
*  rotations of the reference frame through PHI radians about the
*  old Z-axis, followed by THETA radians about the resulting X-axis,
*  then PSI radians about the resulting Z-axis.
*
*  The axis names can be any of the following, in any order or
*  combination:  X, Y, Z, uppercase or lowercase, 1, 2, 3.  Normal
*  axis labelling/numbering conventions apply;  the xyz (=123)
*  triad is right-handed.  Thus, the 'ZXZ' example given above
*  could be written 'zxz' or '313' (or even 'ZxZ' or '3xZ').  ORDER
*  is terminated by length or by the first unrecognized character.
*
*  Fewer than three rotations are acceptable, in which case the later
*  angle arguments are ignored.  If all rotations are zero, the
*  identity matrix is produced.
*
*  Called:  slDEUL
*
*  P.T.Wallace   Starlink   23 May 1997
*
*  Copyright (C) 1997 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

      CHARACTER*(*) ORDER
      REAL PHI,THETA,PSI,RMAT(3,3)

      INTEGER J,I
      DOUBLE PRECISION W(3,3)

*  Compute matrix in double precision
      CALL slDEUL(ORDER,DBLE(PHI),DBLE(THETA),DBLE(PSI),W)

*  Copy the result
      DO J=1,3
         DO I=1,3
            RMAT(I,J) = REAL(W(I,J))
         END DO
      END DO

      END


      SUBROUTINE RECTC(N,BUF,AMP,PHZ)
C    RECTC COMPUTES THE RECTANGULAR COORDINATES FROM THE POLAR COORDINATES.
C   ARGUMENTS:
C  N    - THE NUMBER OF COORDINATES TO CONVERT. AMP AND PHZ MUST CONTAIN N POINTS.
C  BUF  - THE REAL ARRAY N*2 LONG CONTAINING THE RECTANGULAR COORDINATES.
C  AMP  - THE ARRAY CONTAINING THE AMPLITUDE SPECTRUM.
C  PHZ  - THE ARRAY CONTAINING THE PHASE SPECTRUN.
C
      DIMENSION BUF(1),AMP(1),PHZ(1)
      M=1
      DO 100 I=1,N
         ANGLE = PHZ(I)
         BUF(M) = AMP(I)*COS(ANGLE)
         BUF(M+1) = AMP(I)*SIN(ANGLE)
  100 M=M+2
      RETURN
      END


	SUBROUTINE ZERO(F,X0,EPS,XN)
C
C-Description-----------------------------------------------------------
	IMPLICIT NONE
C
C  Function:
C	Use secant method to find zero of the function.
C  Usage:
C	PS program
C  Arguments:
C   i	F	- The function to be evaluated
C   i	X0	- Point to begin evaluation
C   i	EPS	- 0-eps is close enough
C   o	XN	- Value at which zero is found
C  Notes:
C   .	This routine was written by Dale Plummer
C   .	Reference:
C	This routine is an adaptation of
C	"Rootfinder", _Collected Algorithms from CACM_, vol I,
C	 Algorithm 2, 1980.
C
C-Declarations----------------------------------------------------------
C
C
C  Arguments
C
	REAL X0,EPS,XN
C
C  Parameters
C
	INTEGER IMAX
	PARAMETER (IMAX=40)
C
C  Functions
C
	REAL F
C
C  Locals
C
      REAL X1,FX0,FX1,XNEXT
	INTEGER ITER
C
C-Code------------------------------------------------------------------
C
C    Begin evaluating with X0 and X0+1.
C
	X1=X0+1.
CCC	X1=X0+2.
C
C    Initialize count of iterations.
C
	ITER=0
C
C    Evaluate the current two points.
C
	FX0=F(X0)
	FX1=F(X1)
C
C    Check to see if F(X0) evaluates close enough to zero.
C
1	CONTINUE
	IF (ABS(FX0) .LT. EPS) THEN
	    XN=X0
	    RETURN
	END IF
C
C    Bump iteration count.  Abort if too high.
C
	ITER=ITER+1
	IF (ITER.GT.IMAX) THEN
c	    STOP 'FAILED TO CONVERGE IN ROUTINE ZERO'
		X1=ITER/0.0
	END IF
C
C    Compute next point.
C
	XNEXT=X1 -( (FX1*(X1-X0))/(FX1-FX0) )
C
C    Set the next 2 points.
C
	X0=X1
	FX0=FX1

	X1=XNEXT
	FX1=F(X1)
C
C    Go reevaluate at the two new points.
C
	GO TO 1
	END


! RUN: %python %S/test_folding.py %s %flang_fc1
! Tests folding of complex components
module m
  complex, parameter :: z = (1., 2.)
  logical, parameter :: test_1 = z%re == 1.
  logical, parameter :: test_2 = z%im == 2.
  logical, parameter :: test_3 = real(z+z) == 2.
  logical, parameter :: test_4 = aimag(z+z) == 4.
  type :: t
    complex :: z
  end type
  type(t), parameter :: tz(*) = [t((3., 4.)), t((5., 6.))]
  logical, parameter :: test_5 = all(tz%z%re == [3., 5.])
  logical, parameter :: test_6 = all(tz%z%im == [4., 6.])
end module


module iteration
  ! Module to perform the field iteration
  use globdata
  use io, only: print_array
  implicit none
  include "mpif.h"

  integer :: info

  private
  public :: iterate, par_iterate, stitch

contains

  subroutine iterate
    real(mkt) :: fac1, fac2, fac3
    integer :: i, j, n

    fac1 = d*dt
    fac2 = 1_mkd/dx**2; fac3 = 1_mkd/dy**2

    do n = n_start, n_max
      if ( mod(n,2) == 0 ) then
        do j = 2, nx_loc-1
          do i = 2, ny_loc-1
            T(i,j) = fac1*( (T_old(i+1,j) - 2*T_old(i,j) + T_old(i-1,j))*fac2 + &
              (T_old(i,j+1) - 2*T_old(i,j) + T_old(i,j-1))*fac3 ) + T_old(i,j)
          enddo
        enddo
      else
        do j = 2, nx_loc-1
          do i = 2, ny_loc-1
            T_old(i,j) = fac1*( (T(i+1,j) - 2*T(i,j) + T(i-1,j))*fac2 + &
              (T(i,j+1) - 2*T(i,j) + T(i,j-1))*fac3 ) + T(i,j)
          enddo
        enddo
      endif
    enddo

    ! In case n_max is not even update the T field one last time
    if ( mod(n_max,2) /= 0 ) then
      do j = 2, nx-1
        do i = 2, ny-1
          T(i,j) = fac1*( (T_old(i+1,j) - 2*T_old(i,j) + T_old(i-1,j))*fac2 + &
            (T_old(i,j+1) - 2*T_old(i,j) + T_old(i,j-1))*fac3 ) + T_old(i,j)
        enddo
      enddo
    endif

  end subroutine iterate

  subroutine par_iterate
    real(mkt) :: fac1, fac2, fac3
    real(mkt), dimension(1:ny_loc-2) :: send_buffer, recv_buffer
    integer :: i, j, n, m, ndest, nsrc, send_column, recv_column
    logical :: even

    fac1 = d*dt
    fac2 = 1_mkd/dx**2; fac3 = 1_mkd/dy**2

    ! Iterate
    do n = n_start, n_max
      if ( mod(n,2) == 0 ) then; even = .true.; else; even = .false.; endif

        if ( even ) then
          do j = 2, nx_loc-1
            do i = 2, ny_loc-1
              T(i,j) = fac1*( (T_old(i+1,j) - 2*T_old(i,j) + T_old(i-1,j))*fac2 + &
                (T_old(i,j+1) - 2*T_old(i,j) + T_old(i,j-1))*fac3 ) + T_old(i,j)
            enddo
          enddo
        else
          do j = 2, nx_loc-1
            do i = 2, ny_loc-1
              T_old(i,j) = fac1*( (T(i+1,j) - 2*T(i,j) + T(i-1,j))*fac2 + &
                (T(i,j+1) - 2*T(i,j) + T(i,j-1))*fac3 ) + T(i,j)
            enddo
          enddo
        endif

        ! Exhange ghost layers, first right then left
        exchange: do m = 1, 2
          ! Define exchange direction
          if ( m == 1 ) then
            send_column = nx_loc-1
            recv_column = 1
            ndest = rank+1
            nsrc  = rank-1
            if (ndest == pnum) ndest = MPI_Proc_null ! Check if we are at end
            if (nsrc == -1)    nsrc  = MPI_Proc_null ! columns and if so nullify
          else
            send_column = 2
            recv_column = nx_loc
            ndest = rank-1
            nsrc  = rank+1
            if (ndest == -1)   ndest = MPI_Proc_null
            if (nsrc == pnum)  nsrc  = MPI_Proc_null
          endif

          ! Define buffers to be sent
          if ( even ) then
            do i = 1, ny_loc-2
              send_buffer(i) = T(i+1,send_column)
            enddo
          else
            do i = 1, ny_loc-2
              send_buffer(i) = T_old(i+1,send_column)
            enddo
          endif

          ! Send/recv ghost layers
          call MPI_Sendrecv(send_buffer, ny_loc-2, MPI_Double_precision, &
            ndest, 0, recv_buffer, ny_loc-2, MPI_Double_precision, nsrc, 0, &
            MPI_Comm_world, MPI_Status_ignore, info)
          if ( info /= 0 ) print *, 'Sendrecv error'

          if ( nsrc == -2 ) cycle exchange ! Cycle if source is null

          ! Update ghost layers
          if ( even ) then
            do i = 1, ny_loc-2
              T(i+1,recv_column) = recv_buffer(i)
            enddo
          else
            do i = 1, ny_loc-2
              T_old(i+1,recv_column) = recv_buffer(i)
            enddo
          endif
        enddo exchange
      enddo

      ! In case n_max is not even update the T field one last time
      if ( mod(n_max,2) /= 0 ) then
        do j = 2, nx-1
          do i = 2, ny-1
            T(i,j) = fac1*( (T_old(i+1,j) - 2*T_old(i,j) + T_old(i-1,j))*fac2 + &
              (T_old(i,j+1) - 2*T_old(i,j) + T_old(i,j-1))*fac3 ) + T_old(i,j)
          enddo
        enddo
      endif
    end subroutine par_iterate

    subroutine stitch
      use alloc_mod

      real(8), dimension(:,:), allocatable :: rbuf_T
      integer :: info, irank, cur_nx, cur_ny, i, j, col_count

      if ( rank > 0 ) then
        call MPI_Send(T, size(T,1)*size(T,2), MPI_Double_precision, 0, 0, &
          MPI_Comm_world, info)
      endif

      if ( rank == 0 ) then
        ! Expand the root field array to global size (nx x ny)
        call alloc_field(T, nx, ny, info)

        ! Increment counter denoting the last inserted column (-1 removes g. layer)
        col_count = field_sizes(2)-1

        ! Insert remaining fields
        do irank = 1, pnum-1
          ! Get size of the current array (irank+1 to skip root's index)
          cur_ny = field_sizes((irank+1)*2-1)
          cur_nx = field_sizes((irank+1)*2)

          if ( irank == 1 ) then
            allocate(rbuf_T(cur_ny, cur_nx))
          elseif (cur_ny /= field_sizes(irank*2-1) .or. &
              cur_nx /= field_sizes(irank*2  )) then
              deallocate(rbuf_T)
              allocate(rbuf_T(cur_ny, cur_nx))
            endif

            call MPI_Recv(rbuf_T, cur_ny*cur_nx, MPI_Double_precision, irank, 0,&
              MPI_Comm_world, MPI_Status_ignore, info)

            do j = 2, cur_nx
              do i = 1, cur_ny
                T(i, col_count+j-1) = rbuf_T(i,j)
              enddo
            enddo

            ! Update last column (-2 since internal slices have two ghost layers)
            col_count = col_count+cur_nx-2

          enddo
          deallocate(rbuf_T)
        endif
      end subroutine stitch
    end module iteration


      SUBROUTINE PARPT (RCX,RCY, PARITY, PRVC1X,PRVC1Y, PRVC2X,PRVC2Y,
     1                  XA,YA, X,Y, STEP1,STEP2)

C  PARPT accepts a reference point and 2 vectors and computes a
C  corner of the smallest parallelogram containing a specified
C  rectangle. The corner is found in the direction specified by
C  parity.

C  Input parameters
C    RCX,RCY       : reference point within rectangle
C    PARITY        : +1 to search in direction of vectors, -1 to
C                    search in opposite direction
C    PRVC1X,PRVC1Y : first vector to increment reference point
C    PRVC2X,PRVC2Y : second vector to increment reference point
C    XA,YA         : 4 corners of rectangle to be contained
C  Output parameters
C    X,Y           : corner of parallelogram
C    STEP1,STEP2   : number of steps taken from reference point in
C                    direction of 1st,2nd vector

      INTEGER  PARITY, STEP1, STEP2

      REAL     RCX,RCY, PRVC1X,PRVC1Y, PRVC2X,PRVC2Y, XA(4),YA(4), X,Y
      REAL     A1,B1,C1, A2,B2,C2

C  find first, second boundary lines
      CALL PARLIN (RCX,RCY, PARITY, PRVC1X,PRVC1Y, PRVC2X,PRVC2Y,
     1             XA,YA, A1,B1,C1, STEP1)
      CALL PARLIN (RCX,RCY, PARITY, PRVC2X,PRVC2Y, PRVC1X,PRVC1Y,
     1             XA,YA, A2,B2,C2, STEP2)
C  intersection of lines is corner
      CALL LINTPT (A1,B1,C1, A2,B2,C2, X,Y)

      END


*DECK CSPDI
      SUBROUTINE CSPDI (AP, N, KPVT, DET, WORK, JOB)
C***BEGIN PROLOGUE  CSPDI
C***PURPOSE  Compute the determinant and inverse of a complex symmetric
C            matrix stored in packed form using the factors from CSPFA.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2C1, D3C1
C***TYPE      COMPLEX (SSPDI-S, DSPDI-D, CHPDI-C, CSPDI-C)
C***KEYWORDS  DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX,
C             PACKED, SYMMETRIC
C***AUTHOR  Bunch, J., (UCSD)
C***DESCRIPTION
C
C     CSPDI computes the determinant and inverse
C     of a complex symmetric matrix using the factors from CSPFA,
C     where the matrix is stored in packed form.
C
C     On Entry
C
C        AP      COMPLEX (N*(N+1)/2)
C                the output from CSPFA.
C
C        N       INTEGER
C                the order of the matrix A .
C
C        KVPT    INTEGER(N)
C                the pivot vector from CSPFA.
C
C        WORK    COMPLEX(N)
C                work vector.  Contents ignored.
C
C        JOB     INTEGER
C                JOB has the decimal expansion  AB  where
C                   if  B .NE. 0, the inverse is computed,
C                   if  A .NE. 0, the determinant is computed.
C
C                For example, JOB = 11  gives both.
C
C     On Return
C
C        Variables not requested by JOB are not used.
C
C        AP     contains the upper triangle of the inverse of
C               the original matrix, stored in packed form.
C               The columns of the upper triangle are stored
C               sequentially in a one-dimensional array.
C
C        DET    COMPLEX(2)
C               determinant of original matrix.
C               Determinant = DET(1) * 10.0**DET(2)
C               with 1.0 .LE. ABS(DET(1)) .LT. 10.0
C               or DET(1) = 0.0.
C
C     Error Condition
C
C        A division by zero will occur if the inverse is requested
C        and  CSPCO  has set RCOND .EQ. 0.0
C        or  CSPFA  has set  INFO .NE. 0 .
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  CAXPY, CCOPY, CDOTU, CSWAP
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891107  Corrected category and modified routine equivalence
C           list.  (WRB)
C   891107  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  CSPDI
      INTEGER N,JOB
      COMPLEX AP(*),WORK(*),DET(2)
      INTEGER KPVT(*)
C
      COMPLEX AK,AKKP1,AKP1,CDOTU,D,T,TEMP
      REAL TEN
      INTEGER IJ,IK,IKP1,IKS,J,JB,JK,JKP1
      INTEGER K,KK,KKP1,KM1,KS,KSJ,KSKP1,KSTEP
      LOGICAL NOINV,NODET
      COMPLEX ZDUM
      REAL CABS1
      CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
C
C***FIRST EXECUTABLE STATEMENT  CSPDI
      NOINV = MOD(JOB,10) .EQ. 0
      NODET = MOD(JOB,100)/10 .EQ. 0
C
      IF (NODET) GO TO 110
         DET(1) = (1.0E0,0.0E0)
         DET(2) = (0.0E0,0.0E0)
         TEN = 10.0E0
         T = (0.0E0,0.0E0)
         IK = 0
         DO 100 K = 1, N
            KK = IK + K
            D = AP(KK)
C
C           CHECK IF 1 BY 1
C
            IF (KPVT(K) .GT. 0) GO TO 30
C
C              2 BY 2 BLOCK
C              USE DET (D  T)  =  (D/T * C - T) * T
C                      (T  C)
C              TO AVOID UNDERFLOW/OVERFLOW TROUBLES.
C              TAKE TWO PASSES THROUGH SCALING.  USE  T  FOR FLAG.
C
               IF (CABS1(T) .NE. 0.0E0) GO TO 10
                  IKP1 = IK + K
                  KKP1 = IKP1 + K
                  T = AP(KKP1)
                  D = (D/T)*AP(KKP1+1) - T
               GO TO 20
   10          CONTINUE
                  D = T
                  T = (0.0E0,0.0E0)
   20          CONTINUE
   30       CONTINUE
C
            IF (NODET) GO TO 90
               DET(1) = D*DET(1)
               IF (CABS1(DET(1)) .EQ. 0.0E0) GO TO 80
   40             IF (CABS1(DET(1)) .GE. 1.0E0) GO TO 50
                     DET(1) = CMPLX(TEN,0.0E0)*DET(1)
                     DET(2) = DET(2) - (1.0E0,0.0E0)
                  GO TO 40
   50             CONTINUE
   60             IF (CABS1(DET(1)) .LT. TEN) GO TO 70
                     DET(1) = DET(1)/CMPLX(TEN,0.0E0)
                     DET(2) = DET(2) + (1.0E0,0.0E0)
                  GO TO 60
   70             CONTINUE
   80          CONTINUE
   90       CONTINUE
            IK = IK + K
  100    CONTINUE
  110 CONTINUE
C
C     COMPUTE INVERSE(A)
C
      IF (NOINV) GO TO 240
         K = 1
         IK = 0
  120    IF (K .GT. N) GO TO 230
            KM1 = K - 1
            KK = IK + K
            IKP1 = IK + K
            IF (KPVT(K) .LT. 0) GO TO 150
C
C              1 BY 1
C
               AP(KK) = (1.0E0,0.0E0)/AP(KK)
               IF (KM1 .LT. 1) GO TO 140
                  CALL CCOPY(KM1,AP(IK+1),1,WORK,1)
                  IJ = 0
                  DO 130 J = 1, KM1
                     JK = IK + J
                     AP(JK) = CDOTU(J,AP(IJ+1),1,WORK,1)
                     CALL CAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IK+1),1)
                     IJ = IJ + J
  130             CONTINUE
                  AP(KK) = AP(KK) + CDOTU(KM1,WORK,1,AP(IK+1),1)
  140          CONTINUE
               KSTEP = 1
            GO TO 190
  150       CONTINUE
C
C              2 BY 2
C
               KKP1 = IKP1 + K
               T = AP(KKP1)
               AK = AP(KK)/T
               AKP1 = AP(KKP1+1)/T
               AKKP1 = AP(KKP1)/T
               D = T*(AK*AKP1 - (1.0E0,0.0E0))
               AP(KK) = AKP1/D
               AP(KKP1+1) = AK/D
               AP(KKP1) = -AKKP1/D
               IF (KM1 .LT. 1) GO TO 180
                  CALL CCOPY(KM1,AP(IKP1+1),1,WORK,1)
                  IJ = 0
                  DO 160 J = 1, KM1
                     JKP1 = IKP1 + J
                     AP(JKP1) = CDOTU(J,AP(IJ+1),1,WORK,1)
                     CALL CAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IKP1+1),1)
                     IJ = IJ + J
  160             CONTINUE
                  AP(KKP1+1) = AP(KKP1+1)
     1                         + CDOTU(KM1,WORK,1,AP(IKP1+1),1)
                  AP(KKP1) = AP(KKP1)
     1                       + CDOTU(KM1,AP(IK+1),1,AP(IKP1+1),1)
                  CALL CCOPY(KM1,AP(IK+1),1,WORK,1)
                  IJ = 0
                  DO 170 J = 1, KM1
                     JK = IK + J
                     AP(JK) = CDOTU(J,AP(IJ+1),1,WORK,1)
                     CALL CAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IK+1),1)
                     IJ = IJ + J
  170             CONTINUE
                  AP(KK) = AP(KK) + CDOTU(KM1,WORK,1,AP(IK+1),1)
  180          CONTINUE
               KSTEP = 2
  190       CONTINUE
C
C           SWAP
C
            KS = ABS(KPVT(K))
            IF (KS .EQ. K) GO TO 220
               IKS = (KS*(KS - 1))/2
               CALL CSWAP(KS,AP(IKS+1),1,AP(IK+1),1)
               KSJ = IK + KS
               DO 200 JB = KS, K
                  J = K + KS - JB
                  JK = IK + J
                  TEMP = AP(JK)
                  AP(JK) = AP(KSJ)
                  AP(KSJ) = TEMP
                  KSJ = KSJ - (J - 1)
  200          CONTINUE
               IF (KSTEP .EQ. 1) GO TO 210
                  KSKP1 = IKP1 + KS
                  TEMP = AP(KSKP1)
                  AP(KSKP1) = AP(KKP1)
                  AP(KKP1) = TEMP
  210          CONTINUE
  220       CONTINUE
            IK = IK + K
            IF (KSTEP .EQ. 2) IK = IK + K + 1
            K = K + KSTEP
         GO TO 120
  230    CONTINUE
  240 CONTINUE
      RETURN
      END


module particles_mod
    use, intrinsic :: iso_fortran_env, only : DP => REAL64
    implicit none

    real(kind=DP), parameter :: e_mass = 0.510999_DP, p_mass = 938.272_DP
    integer, parameter :: e_charge = -1, p_charge = +1

    type :: particle_t
        real(kind=DP) :: x, y, z, mass
        integer :: charge
    end type particle_t

    type :: coordinates_t
        real(kind=DP) :: x, y, z
    end type coordinates_t

contains

    subroutine init_particle(particle)
        implicit none
        type(particle_t), intent(out) :: particle
        real :: r

        particle%x = random_coord()
        particle%y = random_coord()
        particle%z = random_coord()
        call random_number(r)
        if (r < 0.5) then
            particle%mass = e_mass
            particle%charge = e_charge
        else
            particle%mass = p_mass
            particle%charge = p_charge
        end if

    contains

        function random_coord() result(coord)
            implicit none
            real(kind=DP) :: coord

            call random_number(coord)
            coord = 2.0_DP*coord - 1.0_DP
        end function random_coord

    end subroutine init_particle

    function compute_center_of_mass(particles) result(coordinates)
        implicit none
        class(particle_t), dimension(:), intent(in) :: particles
        type(coordinates_t) :: coordinates
        real(kind=DP) :: total_mass
        integer :: i

        coordinates%x = 0.0_DP
        coordinates%y = 0.0_DP
        coordinates%z = 0.0_DP
        total_mass = 0.0_DP
        do i = 1, size(particles)
            associate(particle => particles(i))
                coordinates%x = coordinates%x + particle%mass*particle%x
                coordinates%y = coordinates%y + particle%mass*particle%y
                coordinates%z = coordinates%z + particle%mass*particle%z
                total_mass = total_mass + particle%mass
            end associate
        end do
        coordinates%x = coordinates%x/total_mass
        coordinates%y = coordinates%y/total_mass
        coordinates%z = coordinates%z/total_mass
    end function compute_center_of_mass

    function distance(p1, p2) result(dist)
        implicit none
        type(particle_t), intent(in) :: p1, p2
        real(kind=DP) :: dist

        dist = sqrt((p1%x - p2%x)**2 + (p1%y - p2%y)**2 + (p1%z - p2%z)**2)
    end function distance

    subroutine print_particle(particle)
        implicit none
        type(particle_t), intent(in) :: particle

        print '("coordinates = ", F10.3, 2(", ", F10.3))', &
            particle%x, particle%y, particle%z
        print '("mass = ", F10.3)', particle%mass
        print '("charge = ", I0)', particle%charge
    end subroutine print_particle

end module particles_mod


        SUBROUTINE YCLCRT (CHIRAD, DELTRAD, RETMAT, ISTAT)
*
*  Module number:
*
*  Module name: YCLCRT
*
*  Keyphrase:
*  ----------
*       Polarimetry processing
*
*  Description:
*  ------------
*       Creates Mueller Matrix for Retarder
*
*  FORTRAN name: YCLCRT
*
*  Keywords of accessed files and tables:
*  --------------------------------------
*       none
*
*  Subroutines Called:
*  -------------------
*  CDBS:
*
*  SDAS:
*
*
*  History:
*  --------
*  Version      Date    Author		  Description
*       1       Mar97   M.D. De La Pena   Original Implementation for CALFOS
*                                         based upon code from R. Allen.
*-------------------------------------------------------------------------------
*
* INPUTS:
*       CHIRAD  - Angle of the plane of incidence in radians
*       DELTRAD - Angle of retardance in radians
*
* INPUT/OUTPUT:
*       RETMAT  - Mueller matrix for the retarder
*       ISTAT   - Modified return status
*----------------------------------------------------------------------------
C
C Passed Parameters
C
      DOUBLE PRECISION CHIRAD, DELTRAD, RETMAT(4,4)
      INTEGER ISTAT
C
C Local Variables
C
      DOUBLE PRECISION D, E, G, RATIO
      DOUBLE PRECISION DZERO, DONE, DTWO
C
      PARAMETER (DZERO = 0.0D0)
      PARAMETER (DONE  = 1.0D0)
      PARAMETER (DTWO  = 2.0D0)
C
C----------------------------------------------------------------------------
C
      RATIO = DELTRAD / DTWO
      D = DCOS(DTWO * CHIRAD) * DSIN(RATIO)
      E = DSIN(DTWO * CHIRAD) * DSIN(RATIO)
      G = DCOS(RATIO)
C
C Fill the retardation matrix
C
      RETMAT(1,1) = DONE
      RETMAT(1,2) = DZERO
      RETMAT(1,3) = DZERO
      RETMAT(1,4) = DZERO
      RETMAT(2,1) = DZERO
      RETMAT(2,2) = D * D + G * G - E * E
      RETMAT(2,3) = DTWO * D * E
      RETMAT(2,4) = -DTWO * E * G
      RETMAT(3,1) = DZERO
      RETMAT(3,2) = RETMAT(2,3)
      RETMAT(3,3) = -D * D + G * G + E * E
      RETMAT(3,4) = DTWO * D * G
      RETMAT(4,1) = DZERO
      RETMAT(4,2) = -RETMAT(2,4)
      RETMAT(4,3) = -RETMAT(3,4)
      RETMAT(4,4) = DTWO * G * G - DONE
C
      ISTAT = 0
      RETURN
      END


!#########################################################################
!# ***********************************************************************
!# <name> ttrafo </name>
!# ***********************************************************************
!#
!# <purpose>
!# This module contains routines for the transformation and
!# back-transformation of points between a reference triangle
!# and the "real" element.
!#
!# The following routine can be found in this module:
!#
!# 1.) ttrafo_calcBaryCoord
!#     -> find the barycentric coordinates for a given point (x,y)
!#        in real coordinates.
!#
!# </purpose>
!#########################################################################

module ttrafo

  use fsystem

  implicit none

  contains

!<subroutine>
  subroutine ttrafo_calcBaryCoord (Dcoord, dbary1, dbary2, dbary3, &
                                   ddet, dx, dy)

  !<description>
    ! This subroutine is to find the barycentric coordinates for a given
    ! point (x,y) in real coordinates.

    ! Explaination of the transformation:
    !
    ! In contrast to quadrilaterals the linear transformation on triangles
    ! is rather easy when using barycentric coordinates. Each point
    ! (X,Y) in a triangle is identified by a 3-tuple of coordinates
    ! (X1,X2,X3) giving the "relative" position of the point inside the
    ! triangle:
    !
    !        P3                      (0,1)
    !       /  \         Phi           |  \
    !      /    \        <--           |    \
    !     /  p   \                     | R    \
    !    P1------P2                  (0,0)---(1,0)
    !
    ! here:    p = X1*P1 + X2*P2 + X3*P3
    !
    ! The barycentric coordinates are "independent" of the triangle:
    ! When a 3-tuple of barycentric coordinates for a point p is obtained,
    ! this holds for both, the "real" triangle as well as the reference one.
    ! Therefore the corresponting point R of p on the reference triangle
    ! can be obtained by setting:
    !
    !          R = Phi^{-1}(p) = X1*(0,0) + X2*(1,0) + X3*(0,1)
    !
    ! So when the barycentric coordinates are known, the transformation
    ! is trivial and can be included in the code directly. The only crucial
    ! point is to calculate the barycentric coordinates from a set of
    ! corners of a triangle.
  !</description>

  !<input>
    ! coordinates of the element vertices
    real(DP), dimension(2,3), intent(IN) :: Dcoord

    ! coordinated of the evaluation point
    real(DP), intent(IN) :: dx, dy
  !</input>

  !<output>
    ! barycentric coordinate values of (x,y)
    real(DP), intent(OUT) :: dbary1, dbary2, dbary3

    ! determinant for triangle
    real(DP), intent(OUT) :: ddet
  !</output>

!</subroutine>

    !local variables
    real(DP) :: dax, day, dbx, dby, dcx, dcy, ddetInv

    dax = Dcoord(1, 1)
    day = Dcoord(2, 1)
    dbx = Dcoord(1, 2)
    dby = Dcoord(2, 2)
    dcx = Dcoord(1, 3)
    dcy = Dcoord(2, 3)

    ! Example where to find this formula here:
    ! http://home.t-online.de/home/nagel.klaus/matdir/bary.htm

    ddet = dax*(dby-dcy) + dbx*(dcy-day) + dcx*(day-dby)
    if (ddet .eq. 0.0_DP) then
      print *, 'ttrafo_calcBaryCoord: Critical error! Determinant is zero.'
      stop
    end if

    ddetInv = 1.0_DP / ddet
    dbary1 = (dx *(dby-dcy)+dbx*(dcy-dx )+dcx*(dy -dby)) * ddetInv
    dbary2 = (dax*(dy -dcy)+dx *(dcy-day)+dcx*(day-dy )) * ddetInv
    dbary3 = (dax*(dby-dy )+dbx*(dy -day)+dx *(day-dby)) * ddetInv

  end subroutine ttrafo_calcBaryCoord

end module


  !***********************************************************************************
    SUBROUTINE SetRotMat(imult)
    !c----------------------------------------------------------------------
    !c
    !c----------------------------------------------------------------------
    use varmod
    implicit none
    ! Declare dummy arguments
    INTEGER, INTENT(IN) :: imult

    ! Declare local variables
    REAL :: afac1,afac2,sina,sinb,sint,cosa,cosb,cost
    REAL :: alpha,beta,theta
    !
    ! Converts the input angles to three angles which make more
    ! mathematical sense:
    !
    !         alpha   angle between the major axis of anisotropy and the
    !                 E-W axis. Note: Counter clockwise is positive.
    !         beta    angle between major axis and the horizontal plane.
    !                 (The dip of the ellipsoid measured positive down)
    !         theta   Angle of rotation of minor axis about the major axis
    !                 of the ellipsoid.
    !
    IF(sang1(imult)>=0.0.and.sang1(imult)<270.0) then
        alpha=(90.0-sang1(imult))*DEG2RAD
    ELSE
        alpha=(450.0-sang1(imult))*DEG2RAD
    ENDIF
    beta=-1.0*sang2(imult)*DEG2RAD
    theta=sang3(imult)*DEG2RAD
    !
    ! Get the required sines and cosines:
    !
    sina  = sin(alpha)
    sinb  = sin(beta)
    sint  = sin(theta)
    cosa  = cos(alpha)
    cosb  = cos(beta)
    cost  = cos(theta)
    !
    ! Construct the rotation matrix in the required memory:
    !
    afac1 = 1.0 / max(sanis1(imult),EPSILON)
    afac2 = 1.0 / max(sanis2(imult),EPSILON)
    rotmat(1,1) = cosb * cosa
    rotmat(1,2) = cosb * sina
    rotmat(1,3) = -sinb
    rotmat(2,1) = afac1*(-cost*sina + sint*sinb*cosa)
    rotmat(2,2) = afac1*(cost*cosa + sint*sinb*sina)
    rotmat(2,3) = afac1*( sint * cosb)
    rotmat(3,1) = afac2*(sint*sina + cost*sinb*cosa)
    rotmat(3,2) = afac2*(-sint*cosa + cost*sinb*sina)
    rotmat(3,3) = afac2*(cost * cosb)

    END SUBROUTINE SetRotMat
    !***********************************************************************************


!  *********************************************************************
!  *                                                                   *
!  *                         subroutine las2i                          *
!  *                                                                   *
!  *********************************************************************
!  Single Precision Version 3.41
!  Written by Gordon A. Fenton, TUNS, Aug. 26, 1992
!  Latest Update: Jun 9, 1999
!
!  PURPOSE   initializes parameters for LAS2G
!
!  This routine sets up the matrices required by LAS2G to construct
!  realizations of the random field. The covariances between local averages
!  at each subdivision stage are computed in double precision for accuracy,
!  but the final construction matrices are stored in single precision and
!  returned to the calling routine via the argument list. The general
!  recursive field construction follows the relationship
!
!         {Z^j} = [A^T]{Z^(j-1)} + [C]{U}
!
!  where {Z^j} is a vector of length 4 representing the values assigned to
!  the 2 x 2 cell subdivision and {Z^(j-1)} are the parent cell values in
!  some neighbourhood. The following figure illustrates the cell subdivision,
!  the neighbourhood, and the numbering scheme for an interior cell (special
!  subsets of the neighbourhood are used for the corners and sides):
!
!                ----------------------------------------
!                |            |            |            |
!                |            |            |            |
!                |     7      |     8      |      9     |
!                |            |            |            |
!                |            |            |            |
!                |------------|------------|------------|
!                |            | 3   |    4 |            |
!                |            |     |      |            |
!                |     4      |-----5------|      6     |
!                |            |     |      |            |
!                |            | 1   |    2 |            |
!                |------------|------------|------------|
!                |            |            |            |
!                |            |            |            |
!                |     1      |     2      |     3      |
!                |            |            |            |
!                |            |            |            |
!                ----------------------------------------
!
!  We see that for the upper left corner, the parent cell neighbourhood used
!  consists of just cells {4,5,7,8} and similarly for the other corners and
!  sides.
!
!  The first stage of the simulation involves the direct generation of a
!  k1 x k2 cell array, where k1 and k2 are integers which satisfying the
!  decomposition N1 = k1*2**m, N2 = k2*2**m for a common factor 2**m. The
!  integers k1 and k2 are chosen to be as large as possible while requiring
!  the product k1*k2 to be less than or equal to MXK. Note that the direct
!  simulation involves the inversion of a MXK x MXK matrix (at the upper
!  limit) and so MXK should not be overly large.
!  This formulation is somewhat less restrictive than simply requiring
!  N1 and N2 to be powers of 2. Also N1 and N2 do not have to be equal.
!  However N1 and N2 cannot still be chosen arbitrarily, for example the
!  set (N1,N2) = (336,256) results in k1 = 21, k2 = 16, m = 4 which is
!  not acceptable here (since k1*k2 > MXK for MXK = 256), while the set
!  (N1,N2) = (160,256) is acceptable since k1 = 10, k2 = 16, m = 4. In general
!  it may be easier to choose k1, k2, and m before specifying N1 and N2. In
!  the event that an unacceptable (k1,k2,m) combination is selected, IERR
!  is set to -1 and control returned to the calling routine.
!  The maximum value of m is set by the calling routine in the argument MXM.
!
!  Arguments to this routine are as follows;
!
! dvarfn  external real*8 function which returns the variance of the random
!         process averaged over a given area. dvarfn is referenced as follows
!
!                var = dvarfn( V1, V2 )
!
!         where (V1,V2) are the side dimensions of the rectangular averaging
!         domain. Any other parameters to the function may be passed by
!         common block from the calling routine. Note that the variance of
!         the random process averaged over the area (V1 x V2) is the product
!         of the point variance and the traditionally defined "variance"
!         function, as discussed by Vanmarcke (pg 186).
!
!  N1,N2  number of cells to discretize the field in the x and y directions
!         respectively (corresponding to the first and second indices of Z
!         respectively). Both N1 and N2 must have the form N1 = k1 * 2**m
!         and N2 = k2 * 2**m where m is common to both and k1 and k2 are
!         positive integers satisfying k1*k2 <= MXK. Generally k1 and k2
!         are chosen to be as large as possible and still satisfy the above
!         requirements so the the first stage involves directly simulating
!         a k1 x k2 field by inversion of a covariance matrix.
!         A potential example is (N1,N2) = (160,256) which gives k1 = 5,
!         k2 = 8, and m = 5. Note that in general N1 and N2 cannot be chosen
!         arbitrarily - it is usually best to choose m first then
!         k1 and k2 so as to satisfy or exceed the problem requirements. Note
!         that because of the requirements on k1*k2, N1 cannot be more than
!         MXK times as big (or smaller) than N2. (input)
!
!  XL,YL  physical dimensions of the process. (input)
!
!  KSEED  integer seed to be used for the pseudo-random number generator.
!         If KSEED = 0, then a random seed will be used (based on the
!         process ID of the current program -- see iseed.f).
!         On output, KSEED is set to the value of the actual seed used.
!
!    MXM  integer giving the largest value that M can take. An error is
!         generated if the process size is such that M > MXM. (input)
!
!    C0   real vector containing the upper triangular values of the Cholesky
!         decomposition of the covariance matrix for the initial stage (0) of
!         k1 x k2 cells. (output)
!
!    CT   real vector containing the upper triangular values of the Cholesky
!         decomposition of the covariance matrix for the k1 or k2 = 1 special
!         case. (output)
!
!    CC   real vector containing the upper triangular values of the Cholesky
!         decomposition of the covariance matrix for the corner cell 2 x 2
!         subdivisions. (output)
!
!    CS   real vector containing the upper triangular values of the Cholesky
!         decomposition of the covariance matrix for the side cell 2 x 2
!         subdivisions. (output)
!
!    CI   real vector containing the upper triangular values of the Cholesky
!         decomposition of the covariance matrix for the interior cell 2 x 2
!         subdivisions. (output)
!
!    AT   real array containing the best linear estimation coefficients for
!         the k1 or k2 = 1 special case. (output)
!
!    AC   real array containing the best linear estimation coefficients for
!         the corner cell subdivisions. (output)
!
!    AS   real array containing the best linear estimation coefficients for
!         the side cell subdivisions. (output)
!
!    AI   real array containing the best linear estimation coefficients for
!         the interior cell subdivisions. (output)
!
!     M   the number of 2 x 2 subdivisions to perform. It is an error for
!         M to be greater than MXM. (output)
!
! k1,k2   integers giving the size of the initial field (see C0). It is an
!         error for the product k1*k2 to exceed MXK. (output)
!
!    kk   integer giving the size of the initial field covariance matrix
!         (kk = k1*k2). (output)
!
!  iout   unit number to which error and warning messages are logged. (input)
!
!   tol   maximum relative error allowed in the Cholesky decomposition of
!         covariance matrices before a warning message is issued. (input)
!---------------------------------------------------------------------------
!  PARAMETERS:
!   MXK   represents the maximum number of cells (k1 x k2) in the initial
!         field, k1*k2 <= MXK. If the value of MXK is changed here, it must
!         also be changed in LAS2G.
!
!  Requires:
!    1) from libGAFsim:	ISEED, DCVIT2, DCVMT2, DCHOL2, CORN2D, SIDE2D,
!			INTR2D, DCVAA2, DCVAB2, DSIFA, DSISL, DAXPY, DSWAP,
!			IDAMAX, DDOT
!    2) user defined external variance function (see DVARFN)
!
!  REVISION HISTORY:
!  3.41	replaced dummy dimensions with a (*) for GNU's compiler (Jun 9/99)
!----------------------------------------------------------------------------
      subroutine las2i( dvarfn, N1, N2, XL, YL, kseed, MXM,C0, CT, CC, CS, CI, AT, AC, AS, AI, M,k1, k2, kk, iout, tol )
      parameter ( MXK = 256 )
      real C0(*), CT(6,*), CC(6,4,*), CS(6,4,*), CI(6,*)
      real AT(3,3,*), AC(4,3,4,*), AS(6,3,4,*), AI(9,3,*)
      real*8 R0(MXK*MXK)
      real*8 R(9,9,2), B(4,4), S(9,4)
      real*8 T1, T2, dvarfn, dble
      logical lformR
      integer mc(4,4), ms(6,4), mi(9)
      external dvarfn
      data mc/5,6,8,9, 4,5,7,8, 2,3,5,6, 1,2,4,5/
      data ms/4,5,6,7,8,9, 2,3,5,6,8,9, 1,2,4,5,7,8, 1,2,3,4,5,6/
      data mi/1,2,3,4,5,6,7,8,9/

   1  format(a,a,a)
   2  format(a,e13.4)
   3  format(a,i4,a,i4,a,i4,a)
!						decompose N1 and N2
      k1 = N1
      k2 = N2
      do 10 m = 0, MXM
         kk = k1*k2
         if( kk .le. MXK ) go to 20
         j1 = k1/2
         j2 = k2/2
         if( 2*j1 .ne. k1 .or. 2*j2 .ne. k2 ) go to 15
         k1 = j1
         k2 = j2
  10  continue
  15  write(iout,1)'Error: unable to determine an acceptable combination of k1, k2 and m'
      write(iout,1)'       such that k1*2**m = N1, k2*2**m = N2.'
      write(iout,3)'       k1 = ',k1,', k2 = ',k2,', m = ',m
      write(iout,3)'       (k1*k2 must be less than ',MXK,' and m must be less than ',MXM,')'
      write(iout,1)'       Try changing N1 and N2.'
      stop
!						initialize internal generator
  20  kseed = iseed( kseed )
!						form initial covariance matrix
      T1 = dble(XL)/dble(k1)
      T2 = dble(YL)/dble(k2)
      call dcvit2( dvarfn, R0, kk, R, 9, k1, k2, T1, T2 )

!						and compute its cholesky decomp
      call dchol2( R0, kk, kk, rerr )
      if( rerr .gt. tol ) then
         write(iout,1)'Warning: Cholesky decomposition of stage 0 covariance matrix'
         write(iout,2)'         has maximum relative error of ',rerr
      endif
!						save in real*4 for LAS2G
      L = 0
      do 30 j = 1, kk
      do 30 i = 1, j
         L = L + 1
         C0(L) = R0(i+(j-1)*kk)
  30  continue
!						setup for subsequent stages
      in = 2
      io = 1
      nm = 1
      if( (k1 .eq. 1 .or. k2 .eq. 1) .and. M .gt. 0 ) then
!							special k1,k2 = 1 case
         T1 = 0.5d0*T1
         T2 = 0.5d0*T2
!							get basic cov matrices
         lformR = (1 .lt. M)
         call dcvmt2(dvarfn,R(1,1,in),9,B,4,S,9,T1,T2,lformR)
         i2 = 5
         if( k1 .eq. 1 ) then
            i1 = 2
            i3 = 8
         else
            i1 = 4
            i3 = 6
         endif
         call thin1d(R(1,1,io),9,B,4,S,9,AT,3,AT(1,1,2),3,CT,CT(1,2),i1,i2,i3,3,iout,tol)
         in = 1
         io = 2
         nm = 2
      endif

      do 40 k = nm, M
         T1 = 0.5d0*T1
         T2 = 0.5d0*T2
!							get basic cov matrices
         lformR = (k .lt. M)
         call dcvmt2(dvarfn,R(1,1,in),9,B,4,S,9,T1,T2,lformR)

!							corner parameters

         call corn2d(R(1,1,io),9,B,4,S,9,CC(1,1,k),6,3,AC(1,1,1,k),mc,iout,tol)
!							side parameters

         call side2d(R(1,1,io),9,B,4,S,9,CS(1,1,k),6,3,AS(1,1,1,k),ms,iout,tol)
!							interior parameters

         call intr2d(R(1,1,io),9,B,4,S,9,CI(1,k),3,AI(1,1,k),mi,iout,tol)
!							swap old/new indices
         ii = in
         in = io
         io = ii
  40  continue

      return
      end