! -*- Mode: Fortran90; -*-
!-----------------------------------------------------------------
! Daniel R. Reynolds
! SMU, Mathematics
! Math 6370
! 9 January 2009
!=================================================================

program ChemicalEquilibrium
  !-----------------------------------------------------------------
  ! Description:
  !    Computes the equilibrium chemical densities at a number of
  !    spatial locations, given a (random) background temperature
  !    field.  The chemical rate equations and solution strategy
  !    are in the subroutine chem_solver, which is called at every
  !    spatial location.
  !-----------------------------------------------------------------
  !======= Inclusions ===========
  implicit none

  !======= Interfaces ===========
  interface
     subroutine chem_solver(T,u,v,w,lam,eps,maxit,its,res)
       integer, intent(in) :: maxit
       integer, intent(out) :: its
       double precision, intent(in) :: T, lam, eps
       double precision, intent(out) :: res
       double precision, intent(inout) :: u, v, w
     end subroutine chem_solver
  end interface

  !======= Declarations =========
  integer :: n, i, maxit, its
  double precision, allocatable :: T(:), u(:), v(:), w(:)
  double precision :: lam, eps, res, stime, ftime

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

  ! set solver input parameters
  maxit = 1000000
  lam = 1.d-2
  eps = 1.d-10

  ! input the number of intervals
  write(*,*) 'Enter the number of intervals (0 quits):'
  read(*,*) n
  if (n < 1) then
     stop
  endif

  ! allocate temperature and solution arrays
  allocate(T(n),u(n),v(n),w(n))

  ! set random temperature field, initial guesses at chemical densities
  call random_number(T)
  u = 0.35d0
  v = 0.1d0
  w = 0.5d0

  ! start timer
  call get_time(stime)

  ! call solver over n intervals
  do i=1,n,1
     call chem_solver(T(i),u(i),v(i),w(i),lam,eps,maxit,its,res)
     if (res < eps) then
        write(*,'(2(A,i8))') '    i =',i,',  its =',its
     else
        write(*,'(2(A,i8),4(A,es9.2))') '    error: i =',i,',  its =',its, &
             ',  res =',res,',  u =',u(i),',  v =',v(i),',  w =',w(i)
        stop
     endif
  enddo

  ! stop timer
  call get_time(ftime)

  ! output solution time
  write(*,*) '     runtime =',ftime-stime

  ! free temperature and solution arrays
  deallocate(T,u,v,w)

end program ChemicalEquilibrium
!=================================================================


MODULE MODULE_NETWORK

USE MODULE_SORT

CONTAINS

SUBROUTINE SORTED_NODES_BY_PROBABILITY(order, T_pn, n_nodes)

    IMPLICIT NONE

    INTEGER, INTENT(IN):: n_nodes
    DOUBLE PRECISION, DIMENSION(n_nodes), INTENT(IN):: T_pn
    INTEGER, DIMENSION(n_nodes), INTENT(OUT):: order

    CALL ARGSORT_REVERSE(T_pn, order)

    order(:)=order(:)-1

END SUBROUTINE

SUBROUTINE COMPONENTS(num_comp,componente,T_start,T_ind,n_nodes,n_edges)

    IMPLICIT NONE

    INTEGER,INTENT(IN)::n_nodes,n_edges
    INTEGER,DIMENSION(n_edges),INTENT(IN)::T_ind
    INTEGER,DIMENSION(n_nodes+1),INTENT(IN)::T_start

    INTEGER,DIMENSION(n_nodes),INTENT(OUT)::componente
    INTEGER,INTENT(OUT)::num_comp

    INTEGER::i,j,jj,g,gg,h

    componente=0
    num_comp=0

    DO i=1,n_nodes

        IF (componente(i)==0) THEN
            num_comp=num_comp+1
            g=num_comp
            componente(i)=g
        ELSE
            g=componente(i)
        END IF

        DO j=T_start(i)+1,T_start(i+1)
            jj=T_ind(j)
            IF (componente(jj)==0) THEN
                componente(jj)=g
            ELSE
                IF (componente(jj)/=g) THEN
                    IF (componente(jj)<g) THEN
                        gg=componente(jj)
                    ELSE
                        gg=g
                        g=componente(jj)
                    END IF
                    DO h=1,n_nodes
                        IF (componente(h)==g) THEN
                            componente(h)=gg
                        ELSE
                            IF (componente(h)>g) componente(h)=componente(h)-1
                        END IF
                    END DO
                    g=gg
                    num_comp=num_comp-1
                END IF
            END IF
        END DO
    END DO

    componente=componente-1

END SUBROUTINE COMPONENTS

END MODULE MODULE_NETWORK

!! f2py --f90flags='-fast' -c -m pyn_fort_net pyn_fort_net.f90
!!f2py --f90flags='-fast' -c -m pyn_fort_net pyn_fort_net.f90 -lmkl_intel_lp64 -lmkl_sequential -lmkl_core -lmkl_def -lpthread


module foo
  implicit none

contains

  subroutine calc(nx, ny, a, b, c)
    implicit none
    integer,intent(in) :: nx,ny
    real(KIND=4),dimension(:,:),intent(in)  :: a,b
    real(KIND=4),dimension(:,:),intent(out) :: c
    integer :: i,j

    !$acc kernels present(a,b,c)
    !$acc loop independent
    do j = 1,ny
       !$acc loop independent
       do i = 1,nx
          c(i,j) = c(i,j) + a(i,j) + b(i,j)
       end do
    end do
    !$acc end kernels

  end subroutine calc

  subroutine init_cpu(nx, ny, a)
    implicit none
    integer,intent(in) :: nx,ny
    real(KIND=4),dimension(:,:),intent(out)  :: a
    integer :: i,j

    do j = 1, ny
       do i = 1, nx
          a(i,j) = 1.0
       end do
    end do
  end subroutine init_cpu

end module foo

program main
  use foo
  implicit none

  integer :: nt = 1000
  integer :: nx = 4096
  integer :: ny = 4096
  real(KIND=4),allocatable,dimension(:,:) :: a,b,c
  real(KIND=4) :: b0
  real(KIND=8) :: t_s, t_e, sum, omp_get_wtime
  integer :: i,j,icnt

  allocate(a(nx,ny),b(nx,ny),c(nx,ny))

  b0 = 2.0

  t_s = omp_get_wtime()

  !**** Begin ****!

  call init_cpu(nx, ny, a)

  !$acc data copyin(a) create(b,c)
  !$acc kernels present(b)
  !$acc loop independent
  do j = 1,ny
     !$acc loop independent
     do i = 1,nx
        b(i,j) = b0
     end do
  end do
  !$acc end kernels

  !$acc kernels present(c)
  c(:,:) = 0.0
  !$acc end kernels

  do icnt = 1,nt
     call calc(nx, ny, a, b, c)
  end do

  sum = 0
  !$acc kernels present(c)
  !$acc loop reduction(+:sum)
  do j = 1,ny
     !$acc loop reduction(+:sum)
     do i = 1,nx
        sum = sum + c(i,j)
     end do
  end do
  !$acc end kernels
  !$acc end data

  !**** End ****!

  t_e = omp_get_wtime()
  print *, "mean =", sum/(nx*ny)
  print *, "Time =", t_e-t_s

  deallocate(a,b,c)

end program main


C$Procedure      PLTNP ( Nearest point on triangular plate )

      SUBROUTINE PLTNP ( POINT, V1, V2, V3, PNEAR, DIST )

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

      IMPLICIT NONE

      DOUBLE PRECISION      POINT ( 3 )
      DOUBLE PRECISION      V1    ( 3 )
      DOUBLE PRECISION      V2    ( 3 )
      DOUBLE PRECISION      V3    ( 3 )
      DOUBLE PRECISION      PNEAR ( 3 )
      DOUBLE PRECISION      DIST

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     POINT      I   A point in 3-dimensional space.
C     V1,
C     V2,
C     V3         I   Vertices of a triangular plate.
C     PNEAR      O   Nearest point on the plate to POINT.
C     DIST       O   Distance between PNEAR and POINT.
C
C$ Detailed_Input
C
C     POINT      is an arbitrary point in 3-dimensional space.
C
C     V1,
C     V2,
C     V3         are 3-vectors constituting the vertices of
C                a triangular plate.
C
C                The plate is allowed to be degenerate: it may
C                consist of a line segment or of a single point.
C
C$ Detailed_Output
C
C     PNEAR      is the closest point on the plate to POINT.
C                PNEAR is unique, since the plate is convex.
C
C     DIST       is the distance between POINT and PNEAR.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1) The input plate is allowed to be degenerate: it may be
C        a line segment or a single point.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     None.
C
C$ Examples
C
C     The numerical results shown for these examples may differ across
C     platforms. The results depend on the SPICE kernels used as input
C     (if any), the compiler and supporting libraries, and the machine
C     specific arithmetic implementation.
C
C
C     1) Find the nearest point to the point (2,2,2) on a plate having
C        vertices at the unit basis vectors that lie along the positive
C        X, Y, and Z coordinate axes.
C
C
C        Example code begins here.
C
C
C              PROGRAM EX1
C              IMPLICIT NONE
C
C        C
C        C     Local parameters
C        C
C              CHARACTER*(*)         FMT1
C              PARAMETER           ( FMT1 = '(A,3E16.8)' )
C        C
C        C     Local variables
C        C
C              DOUBLE PRECISION      DIST
C              DOUBLE PRECISION      POINT  ( 3 )
C              DOUBLE PRECISION      PNEAR  ( 3 )
C              DOUBLE PRECISION      V1     ( 3 )
C              DOUBLE PRECISION      V2     ( 3 )
C              DOUBLE PRECISION      V3     ( 3 )
C
C        C
C        C     POINT is the input point.
C        C
C              CALL VPACK ( 2.D0, 2.D0, 2.D0, POINT )
C        C
C        C     V1, V2, V3 are the vertices of a plate.
C        C
C              CALL VPACK ( 1.D0, 0.D0, 0.D0, V1 )
C              CALL VPACK ( 0.D0, 1.D0, 0.D0, V2 )
C              CALL VPACK ( 0.D0, 0.D0, 1.D0, V3 )
C        C
C        C     Find the near point on the plate.
C        C
C              CALL PLTNP ( POINT, V1, V2, V3, PNEAR, DIST )
C
C              WRITE (*,*) ' '
C              WRITE (*,FMT1) 'Plate vertex 1 = ', V1
C              WRITE (*,FMT1) 'Plate vertex 3 = ', V2
C              WRITE (*,FMT1) 'Plate vertex 3 = ', V3
C              WRITE (*,FMT1) 'Input point    = ', POINT
C              WRITE (*,*)    ' '
C              WRITE (*,FMT1) 'Near point     = ', PNEAR
C              WRITE (*,FMT1) 'Distance       = ', DIST
C              WRITE (*,*) ' '
C
C              END
C
C
C     When this program was executed on a PC/Linux/gfortran platform,
C     the output was:
C
C
C      Plate vertex 1 =   0.10000000E+01  0.00000000E+00  0.00000000E+00
C      Plate vertex 3 =   0.00000000E+00  0.10000000E+01  0.00000000E+00
C      Plate vertex 3 =   0.00000000E+00  0.00000000E+00  0.10000000E+01
C      Input point    =   0.20000000E+01  0.20000000E+01  0.20000000E+01
C
C      Near point     =   0.33333333E+00  0.33333333E+00  0.33333333E+00
C      Distance       =   0.28867513E+01
C
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.1.2, 01-FEB-2016 (NJB)
C
C        Added code example to header.
C
C-    DSKLIB Version 1.1.1, 19-MAR-2015 (NJB)
C
C        Fixed spelling error in header.
C
C-    DSKLIB Version 1.1.0, 31-DEC-2014 (NJB)
C
C        Bug fix: vertex indices for outside case, near
C        point on 3rd edge were corrected.
C
C-    DSKLIB Version 1.0.0, 29-SEP-2014 (NJB)
C
C-&

C$ Index_Entries
C
C     nearest point on triangular plate
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      VDIST
      DOUBLE PRECISION      VDOT
      DOUBLE PRECISION      VNORM

      LOGICAL               RETURN
      LOGICAL               VZERO

C
C     Local variables
C
      DOUBLE PRECISION      D1
      DOUBLE PRECISION      D2
      DOUBLE PRECISION      D3
      DOUBLE PRECISION      E1     ( 3 )
      DOUBLE PRECISION      E2     ( 3 )
      DOUBLE PRECISION      E3     ( 3 )
      DOUBLE PRECISION      ENORM1 ( 3 )
      DOUBLE PRECISION      ENORM2 ( 3 )
      DOUBLE PRECISION      ENORM3 ( 3 )
      DOUBLE PRECISION      L1
      DOUBLE PRECISION      L2
      DOUBLE PRECISION      L3
      DOUBLE PRECISION      NORMAL ( 3 )
      DOUBLE PRECISION      NP1    ( 3 )
      DOUBLE PRECISION      NP2    ( 3 )
      DOUBLE PRECISION      PDIFF  ( 3 )
      DOUBLE PRECISION      PERP   ( 3 )

      LOGICAL               DEGEN
      LOGICAL               IN1
      LOGICAL               IN2
      LOGICAL               IN3

      IF ( RETURN() ) THEN
         RETURN
      END IF

C
C     Use discovery check-in.
C
C
C     Compute the plate's edges.
C
      CALL VSUB ( V2, V1, E1 )
      CALL VSUB ( V3, V2, E2 )
      CALL VSUB ( V1, V3, E3 )

C
C     Compute a normal vector for the plate, if possible.
C     If the plate is degenerate, we'll find out at this point.
C
      CALL VCRSS ( E1, E2, NORMAL )

C
C     Compute the outward normals of the plate's edges in the
C     plate containing the plate.
C
      CALL VCRSS ( E1, NORMAL, ENORM1 )
      CALL VCRSS ( E2, NORMAL, ENORM2 )
      CALL VCRSS ( E3, NORMAL, ENORM3 )

      DEGEN =      VZERO(NORMAL) .OR. VZERO(ENORM1)
     .        .OR. VZERO(ENORM2) .OR. VZERO(ENORM3)

      IF ( DEGEN ) THEN
C
C        The "plate" is a line segment or point. Determine
C        which case we have.
C
         L1 = VNORM(E1)
         L2 = VNORM(E2)
         L3 = VNORM(E3)

         IF ( ( L1 .EQ. 0.D0 ) .AND. ( L2 .EQ. 0.D0 ) ) THEN
C
C           Up to round-off error, the vertices coincide.
C           The vertex V1 for practical purposes is the plate.
C
            CALL VEQU ( V1, PNEAR )

            DIST = VDIST( PNEAR, POINT )

         ELSE
C
C           The plate is a line segment having positive length.
C           One of the edges will coincide with the segment.
C           Determine which vertices are the endpoints.
C
            IF ( L1 .GT. MAX(L2, L3) ) THEN
C
C              The segment is bounded by V1 and V2.
C
               CALL NPSGPT( V1, V2, POINT, PNEAR, DIST )

            ELSE IF ( L2 .GT. MAX(L3, L1) ) THEN
C
C              The segment is bounded by V2 and V3.
C
               CALL NPSGPT( V2, V3, POINT, PNEAR, DIST )

            ELSE
C
C              The segment is bounded by V3 and V1.
C
               CALL NPSGPT( V3, V1, POINT, PNEAR, DIST )

            END IF

         END IF
C
C        The outputs are set for the degenerate cases.
C
         RETURN

      END IF

C
C     We have a non-degenerate plate. NORMAL has unit length.
C
C     We'll treat V1 as an origin in the plane containing
C     the plate. Find the offset of the POINT from V1, and
C     find the component of this offset orthogonal to NORMAL.
C
      CALL VSUB  ( POINT, V1,     PDIFF )
      CALL VPERP ( PDIFF, NORMAL, PERP  )

C
C     Determine whether V1+PERP is inside the plate.
C
C     Note that the "line constants" for edges 1 and 3
C     are zero, since these edges contain V1. The line
C     constant for edge 2 is that of the offset of V2
C     from V1; this offset is edge 1.
C
      IN1 = VDOT( PERP, ENORM1 ) .LE. 0.D0
      IN2 = VDOT( PERP, ENORM2 ) .LE. VDOT(E1,ENORM2)
      IN3 = VDOT( PERP, ENORM3 ) .LE. 0.D0

      IF ( IN1 .AND. IN2 .AND. IN3 ) THEN
C
C        V1+PERP is inside the plate. It is the closest
C        point on the plate to POINT.
C
         CALL VADD ( V1, PERP, PNEAR )
C
C        We have the near point; set the distance.
C
         DIST = VDIST( PNEAR, POINT )

      ELSE
C
C        PERP is outside the plate. The nearest point
C        on the plate to POINT is on one of the edges.
C
C        We'll use the "in" flags to reduce the number
C        of point-edge distance computations.
C
         IF ( ( .NOT. IN1 ) .AND. ( IN2 .AND. IN3 ) ) THEN
C
C           The solution must be on the first edge.
C
            CALL NPSGPT ( V1, V2, POINT, PNEAR, DIST )

         ELSE IF ( ( .NOT. IN2 ) .AND. ( IN3 .AND. IN1 ) ) THEN

C
C           The solution must be on the second edge.
C
            CALL NPSGPT ( V2, V3, POINT, PNEAR, DIST )

         ELSE IF ( ( .NOT. IN3 ) .AND. ( IN1 .AND. IN2 ) ) THEN
C
C           The solution must be on the third edge.
C
            CALL NPSGPT ( V3, V1, POINT, PNEAR, DIST )

         ELSE
C
C           Compute solutions on all three edges and pick
C           the best one.
C
            CALL NPSGPT ( V1, V2, POINT, NP1,   D1 )
            CALL NPSGPT ( V2, V3, POINT, NP2,   D2 )
            CALL NPSGPT ( V3, V1, POINT, PNEAR, D3 )

            IF ( D1 .LE. MIN(D2, D3) ) THEN

               CALL VEQU ( NP1, PNEAR )
               DIST = D1

            ELSE IF ( D2 .LE. MIN(D3, D1) ) THEN

               CALL VEQU ( NP2, PNEAR )
               DIST = D2

            ELSE
C
C              PNEAR is already set.
C
               DIST = D3

            END IF

         END IF

      END IF

      RETURN
      END


module zn_param_module
 use precision_module, only : wp
 use input_module,     only : maxn, zpeR, zpeX
 use diag_module
 use pes_module

 implicit none
 public

contains

subroutine zn_param_sloped(up_origin,xcross,xpoint,up,down, &
                         aa,dd,bb,r0,binLower,binUpper)

 real(wp), intent(in)     :: up_origin, xcross
 real(wp), dimension(:), intent(inout)  :: xpoint, up, down
 real(wp), intent(out)    :: aa, dd, r0
 integer,          intent(out)    :: binLower, binUpper
 real(wp), dimension(:), intent(out) :: bb
 integer          :: i, r0_index
 integer          :: t1_index, t2_index, itarget,k, ispec
 real(wp) :: Ex, E1t1, E1t2, E2t1, E2t2, E1r0, E2r0
 real(wp) :: bb_tmp
 real(wp) :: gap, x0, E1x0, E2x0, t1, t2
 real(wp) :: xval, Eup, Edown
 real(wp), allocatable :: diffUpDown(:)

allocate(diffUpDown(maxn))

! Find approximate r0 value.

! Find gap between two states.
diffUpDown = abs(up-down)
r0_index = minloc(diffUpDown,1)
r0 = xpoint(r0_index)
E2r0 = up(r0_index)
E1r0 = down(r0_index)
gap  = E2r0-E1r0
Ex   = (E2r0+E1r0)/2.0d0

! Find precise r0, E1r0, and E2r0 values.

! call find_extremum(r0,3, x0,E1x0,E2x0)
! find_extremum subroutine works, but
! highly depends on an initial guess; minimize_func is used instead.
k = 0
! Means that target function is a gap.
 call minimize_func(k,xcross, x0,E1x0,E2x0)
 xpoint(r0_index) = x0
! Replace E1r0 value in down array.
 down(r0_index) = E1x0
! Replace E2r0 value in up array.
 up(r0_index) = E2x0
! Replace r0 value in xpoint array.
 r0 = xpoint(r0_index)
! Update E1r0.
 E1r0 = down(r0_index)
! Update E2r0
 E2r0  =  up(r0_index)
 Ex=(E2r0+E1r0)/2.0d0

! Find approximate t1,t2, E1t1 and E2t2 values.

! Initial guess.
t2_index = r0_index
t2 = xpoint(t2_index)
do while (up(t2_index) .gt. Ex)
  t2_index = t2_index - 1
end do

! Initial guess.
t1_index = r0_index
t1 = xpoint(t1_index)
do while ((down(t1_index) .lt. Ex) .and. (t1_index .lt. size(down)))
  t1_index = t1_index+1
enddo

t1   =  xpoint(t1_index)
t2   =  xpoint(t2_index)
E1t1 =    down(t1_index)
E2t1 =      up(t1_index)
E2t2 =      up(t2_index)
E1t2 =    down(t2_index)

! Find precise t1, E1t1 and E2t1 values.

k = 1
 call find_x(t1,Ex,k, xval,Eup,Edown)
! Replace t1 value in xpoint array.
 xpoint(t1_index) = xval
! Replace E1t1 value in down array.
 down(t1_index) = Edown
! Replace t1 value in up array.
 up(t1_index) = Eup
! Update t1.
 t1   = xpoint(t1_index)
! Update E1t1.
 E1t1 =   down(t1_index)
! Update E2t1.
 E2t1 =   up(t1_index)

! Find precise t2 and E2t2 values.

k = 4
 call find_x(t2,Ex,k, xval,Eup,Edown)
! Replace t2 value in xpoint array.
 xpoint(t2_index) = xval
! Replace E1t2 value in down array.
 down(t2_index) = Edown
! Replace E2t2 value in up array.
 up(t2_index) = Eup
! Update t2.
 t2   = xpoint(t2_index)
! Update E1t2.
 E1t2 =   down(t2_index)
! Update E2t2.
 E2t2 =   up(t2_index)

! Shift the origin to the reactant.

up   = up - up_origin
down = up - up_origin
E1r0 = E1r0 - up_origin
E2r0 = E2r0 - up_origin
E1t1 = E1t1 - up_origin
E2t1 = E2t1 - up_origin
E1t2 = E1t2 - up_origin
E2t2 = E2t2 - up_origin

! Determine energy regimes.

binLower = ceiling(E1r0*autocm)
binUpper = ceiling(E2r0*autocm)

! Compute aa and bb adiabatic parameters.

bb = 0.0d0
dd = (E2t1-E1t1)*(E2t2-E1t2)/(E2r0-E1r0)**2.0d0
aa = sqrt(dd-1.0d0)/(redmass*(t2-t1)**2.0d0*(E2r0-E1r0))
do i= 1, maxn
  bb_tmp = sqrt(dd-1.0d0)*(dble(i)/autocm-(E2r0+E1r0)/2.0d0+zpeR-zpeX)
  bb(i)  = 2.0d0*bb_tmp/(E2r0-E1r0)
enddo

! Print critical points & adiabatic parameters.

!   print *,'bb(1) is              ', bb(1)
!   print *,'aa and dd are      ',aa, dd
!   print *,'Ex is              ',Ex
!   print *,'r0 and r0_index are',r0, r0_index
!   print *,'t2 and t2_index are',t2, t2_index
!   print *,'t1 and t1_index are',t1, t1_index
!   print *,'E1t1 and E1t2 are', E1t1, E1t2
!   print *,'E2t1 and E2t2 are', E2t1, E2t2
!   print *,'E2r0 and E1r0 are', E2r0, E1r0

! Print adiabatic energies.

open(21,file='adiabatic_energies.out')
write(21,*) "#bin     ","xpoint    ", "up      ","down      "
do i=1, maxn
  write (21,*) i, xpoint(i), up(i), down(i)
enddo
close(21)

end subroutine zn_param_sloped

subroutine zn_param_peaked(origin,xcross, &
                        aa,bb,binLower,binUpper,down_origin)

 real(wp), intent(in)                :: origin, xcross
 real(wp), intent(out)               :: aa, down_origin
 integer,  intent(out)               :: binLower, binUpper
 real(wp), dimension(:), intent(out) :: bb
 integer          :: i, k
 real(wp) :: x0, deltaE, deltaR, der1, der2, d_up, d_down
 real(wp) :: E1x0, E2x0, Et, Eb, Rt, Rb, h, E1h, E2h, gam

! Determine the adiabatic origin.

! Origin is set to lower state by default.
k = 1
 down_origin = target_func(origin,k)

! Find precise r0, E1r0, and E2r0 values.

! Target function now is an upper state.
k = 4
 call minimize_func(k,xcross, x0,E1x0,E2x0)
 Rb = x0
 Eb = E2x0
! Target function now is a lower state.
k = 1
 call minimize_func(k,xcross, x0,E1x0,E2x0)
 Rt = x0
 Et = E1x0
 h = (Rt + Rb)/two
 k = 1
 E1h =  target_func(h,k)
 k = 4
 E2h =  target_func(h,k)
 deltaE = Eb-Et
 deltaR = Rb-Rt
 gam    = deltaE/(E2h - E1h)

! Shift the origin to the reactant.

Et = Et - down_origin
Eb = Eb - down_origin

! Determine energy regimes.

binLower = ceiling(Et*autocm)
binUpper = ceiling(Eb*autocm)

! Compute aa and bb adiabatic parameters.

if (abs(gam - one) .lt. 1.0d-8) then
  k = 1
    call derivatives(Rt,k, der1,der2)
    d_down = der2
  k = 4
    call derivatives(Rb,k, der1,der2)
    d_up=der2
    aa = (d_up-d_down)/(4.0d0*redmass*deltaE)
else
    aa = (1.0d0-gam**2.0d0)/(redmass*deltaR**2.0d0*deltaE)
endif

do i=1, maxn
  bb(i) = dble(i)/autocm - (Eb + Et)/two + zpeR - zpeX
  bb(i) = two*bb(i)/deltaE
enddo

! Print critical points and adiabatic parameters.

!   print *,'bb(1) is              ', bb(1)
!   print *,'aa and gamma are      ',aa, gam
!   print *,'deltE  is',deltaE
!   print *,'deltaR is',deltaR
!   print *,'Et and Eb are', Et, Eb
!   print *,'Rt and Rb are', Rt, Rb
!   print *,'down origin is', down_origin

end subroutine zn_param_peaked

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

!----------------------GOLDEN SECTION-------------------------------
subroutine minimize_func(k,xcross, x0,E1x0,E2x0)
   real(wp) :: a, b, x1, x2
   real(wp) :: fun1, fun2
   real(wp) :: gratio, threshold, shift
   real(wp) :: der1, der2
   real(wp) :: der1a, der2a
   real(wp) :: der1b, der2b
   integer          :: kk, i
   integer,          intent(in)   :: k
   real(wp), intent(in)   :: xcross
   real(wp), intent(out)  :: x0, E1x0, E2x0

 !FUNCTION is subject to minimization
 !Determine the range where the smallest function value is expected
    shift=1.0d-10
    der1a=1.0d0 !set guess for derivative of FUNCTION at a
    der1b=1.0d0 !set guess for derivative of FUNCTION at b
    do while (der1a*der1b.gt.0) !till dirivatives have oposite signs
       shift=shift*10.d0
       a = xcross-shift    !set guess for a
             call derivatives(a,k, der1,der2)
             der1a = der1
             der2a = der2
       b = xcross+shift    !set guess for b
             call derivatives(b,k, der1,der2)
             der1b = der1
             der2b = der2
    enddo

    gratio=(1.0d0+dsqrt(5.0d0))/2.0d0
    threshold=1.0d-16

    i=0 !Number of the cycle
    do while (ABS(a-b).gt.threshold)

      !if solution is not found within 100 cycles
      !threshold will be rised by one order of magnitude
      i=i+1
      if (mod(i,100).eq.0) then
       threshold=threshold*10.d0
!       print *,'Threshold for extremum has been raised to',threshold
      endif

      !body of golden section cycle
       x1 = b-(b-a)/gratio
       x2 = a+(b-a)/gratio
         fun1 = target_func(x1,k)
         fun2 = target_func(x2,k)

         !Minimize convex potential
         if (der2a.gt.0.0d0 .and. der2b.gt.0.0d0) then
             if (fun1.gt.fun2) then
                 a=x1
             else
                 b=x2
             endif

         !Maximize concave potential
         elseif (der2a.lt.0.0d0 .and. der2b.lt.0.0d0) then
             if (fun1.lt.fun2) then
                 b=x1
             else
                 a=x2
             endif
         endif
    enddo

    x0=a
   kk=4 !4 means that target function is an upper state
      E2x0 = target_func(x0,kk)
   kk=1 !1 means that target function is a lower state
      E1x0 = target_func(x0,kk)
end subroutine minimize_func
!------------------------------------------------------------------

!------------------------------------------------------------------
function target_func(x,k) !returns target function
   integer, intent(in)           :: k
   real(wp), intent(in)  :: x
   real(wp)              :: target_func
   real(wp)              :: e1, e2, eig(2) !eig(4)

   if     (k.eq.1) then   !lower state is a target function
             e1=poly_high(x)
             e2=poly_low(x)
!            call adiabatization(e1,e2,h12,h13,h14,eig)
             call adiabatization(e1,e2,eig)
             target_func=eig(1)

   elseif (k.eq.4) then   !upper state is a target function
             e1=poly_high(x)
             e2=poly_low(x)
!            call adiabatization(e1,e2,h12,h13,h14,eig)
             call adiabatization(e1,e2,eig)
!            target_func=eig(4)
             target_func=eig(2)

   elseif (k.eq.0) then   !gap is a target function
             e1=poly_high(x)
             e2=poly_low(x)
!            call adiabatization(e1,e2,h12,h13,h14,eig)
             call adiabatization(e1,e2,eig)
!            target_func=eig(4)-eig(1)
             target_func=eig(2)-eig(1)
   endif

end function target_func
!------------------------------------------------------------------

!--------------SECANT METHOD---------------------------------------
subroutine find_x(x0,const,k, xval,Eup,Edown)
   integer, intent(in)           :: k
   integer                       :: kk, i
   real(wp), intent(in)  :: x0, const
   real(wp), intent(out) :: xval, Eup, Edown
   real(wp) :: delta, threshold, Ex
   real(wp) :: dx, x, old_x, new_x, f, old_f

     dx=0.001d0 !small arbitrary shift to get new x
     threshold=1.0d-14 ! threshold for deviation in x
     delta=1.0d0 ! arbitrary value to initiate while cycle
     i=0

       Ex=target_func(x0,k)
       old_f=Ex-const
       old_x=x0

       x=x0+dx
       Ex=target_func(x,k)
       f=Ex-const
          do while (delta.gt.threshold)

          !if solution is not found within 100 cycles
          !threshold will be rised by one order of magnitude
          i=i+1
          if (mod(i,100).eq.0) then
           threshold=threshold*10.d0
!           print *,'Threshold for turning point &
!                              has been raised to',threshold
          endif

             new_x=old_x-(old_f*(x-old_x))/(f-old_f)
               old_f=f
               Ex=target_func(new_x,k)
               f=Ex-const
               old_x=x
               x=new_x
             delta=ABS(x-old_x)
          enddo
      xval=x
   kk=4 !4 means that target function is an upper state
      Eup=target_func(xval,kk)
   kk=1 !1 means that target function is a lower state
      Edown=target_func(xval,kk)
end subroutine find_x

!--------------NEWTON'S METHOD--------------------------------
subroutine find_extremum(xini,k, x0,E1x0,E2x0)
   real(wp), intent(in)  :: xini
   integer,          intent(in)  :: k
   real(wp), intent(out) :: x0, E1x0, E2x0
   real(wp) :: delta, threshold
   real(wp) :: x, old_x, gap
   real(wp) :: der1, der2
   integer          :: kk

 !    dx=0.001d0 !small arbitrary shift to get new x
     threshold=1.0d-14 ! threshold for deviation in x
     delta=1.0d0 ! arbitrary value to initiate while cycle
       x=xini
! print *,'threshold >>>>> ',threshold
          do while (delta.gt.threshold)
             call derivatives(x,k, der1,der2)
             old_x=x
             !f=f/(f)
             x=x-der1/der2
             gap=target_func(x,k)

             delta=ABS(x-old_x)
! print *,'REFINED GAP and r0 and delta are ',gap, x, delta
! print *,'!!! 1st and 2nd derivatives are ',der1, der2
          enddo
      x0=x
       kk=4 !
       E2x0=target_func(x0,kk)
       kk=1 !
       E1x0=target_func(x0,kk)
end subroutine find_extremum

subroutine derivatives(x,k, der1,der2)
   real(wp) :: dx, h, f, y0, y1, y2, delta
   real(wp) :: y11, y22, y111, y222
   real(wp), intent(out) :: der1, der2
   real(wp), intent(in)  :: x
   integer,          intent(in)  :: k

   dx=0.0001d0
           h=x
               y0   =  target_func(h,k)

           h=x+dx
               y1   =  target_func(h,k)
           h=x-dx
               y2   =  target_func(h,k)

           h=x+2.0d0*dx
               y11  =  target_func(h,k)
           h=x-2.0d0*dx
               y22  =  target_func(h,k)

           h=x+3.0d0*dx
               y111 =  target_func(h,k)
           h=x-3.0d0*dx
               y222 =  target_func(h,k)

   der1=(y111-9.0d0*y11+45.0d0*y1-45.0d0* &
          y2+9.0d0*y22-y222)/(60.0d0*dx)
   der2=(2.0d0*y111-27.0d0*y11+270.0d0*y1-490.0d0*y0+ &
         270.0d0*y2-27.0d0*y22+2.0d0*y222)/(180.d0*dx*dx)

end subroutine derivatives

subroutine der_spin_diab(x,n, der)
   integer          :: i
   real(wp) :: dx, h
   real(wp) :: p(3), m(3)
   real(wp), intent(out) :: der
   real(wp), intent(in)  :: x
   integer,          intent(in)  :: n

   dx=0.0001d0
   if (n==2) then
        do i=1, 3
           h = x-dx*dble(i)
           m(i)  =  poly_high(h)
        enddo

        do i=1, 3
           h = x+dx*dble(i)
           p(i)  =  poly_high(h)
        enddo

   elseif (n==1) then
        do i=1, 3
           h = x-dx*dble(i)
           m(i)  =  poly_low(h)
        enddo

        do i=1, 3
           h = x+dx*dble(i)
           p(i)  =  poly_low(h)
        enddo
   endif

   der = (p(3)-9.0d0*p(2)+45.0d0*p(1) &
         -m(3)+9.0d0*m(2)-45.0d0*m(1))/(60.0d0*dx)
!           m(1)+9.0d0*m(2)-m(3))/(60.0d0*dx)

end subroutine der_spin_diab
!---------------------------------------------------------------------
end module zn_param_module


module rigid_disk
    implicit none

    type disk
        real  :: radius
        real, dimension(2) :: pos
    end type disk

    type boundary
        real, dimension(2) :: upper, lower, width, half_width
    end type boundary

contains

    real function length_sq(vec)
        implicit none
        real, dimension(2), intent(in) :: vec
        length_sq = vec(1)**2 + vec(2)**2
    end function length_sq

    subroutine restrict_position(pos, bc)
        implicit none
        real, dimension(2), intent(inout) :: pos
        type(boundary), intent(in) :: bc

        if (pos(1) .LT. bc%lower(1)) then
            pos(1) = pos(1) + bc%width(1)
        else if (bc%upper(1) .LT. pos(1)) then
            pos(1) = pos(1) - bc%width(1)
        end if

        if (pos(2) .LT. bc%lower(2)) then
            pos(2) = pos(2) + bc%width(2)
        else if (bc%upper(2) .LT. pos(2)) then
            pos(2) = pos(2) - bc%width(2)
        end if
    end subroutine restrict_position

    subroutine restrict_direction(vec, bc)
        implicit none
        real, dimension(2), intent(inout) :: vec
        type(boundary), intent(in) :: bc

        if (vec(1) .LT. -bc%half_width(1)) then
            vec(1) = vec(1) + bc%width(1)
        else if (bc%half_width(1) .LT. vec(1)) then
            vec(1) = vec(1) - bc%width(1)
        end if

        if (vec(2) .LT. -bc%half_width(2)) then
            vec(2) = vec(2) + bc%width(2)
        else if (bc%half_width(2) .LT. vec(2)) then
            vec(2) = vec(2) - bc%width(2)
        end if
    end subroutine restrict_direction

    logical function overlaps(lhs, rhs, bc)
        implicit none
        type(boundary), intent(in) :: bc
        type(disk),     intent(in) :: lhs, rhs
        real, dimension(2) :: vec
        vec = lhs%pos - rhs%pos
        call restrict_direction(vec, bc)

        overlaps = length_sq(vec) .LT. (lhs%radius + rhs%radius)**2
    end function overlaps

end module rigid_disk

program main
    use rigid_disk
    implicit none

    real,    parameter                    :: radius    = 1.0
    real,    parameter                    :: delta     = 0.3
    integer, parameter                    :: num_disks = 100
    integer                               :: i,j,t, idx
    integer                               :: seedsize
    integer, allocatable, dimension(:)    :: seed, indices
    real,    dimension(2)                 :: lower, upper
    type(boundary)                        :: bc
    type(disk), allocatable, dimension(:) :: disks
    type(disk)                            :: new_disk
    real                                  :: rand
    logical                               :: collides
    real, dimension(2)                    :: vec

    call random_seed(size=seedsize)
    allocate(seed(seedsize))
    do i=1, seedsize
      call system_clock(count=seed(i))
    end do
    call random_seed(put=seed)

    lower = (/ 0.0,  0.0/)
    upper = (/30.0, 30.0/)
    bc%lower      = lower
    bc%upper      = upper
    bc%width      = upper - lower
    bc%half_width = (upper - lower) / 2

    allocate(disks(num_disks))
    do i=1, num_disks
        do
            new_disk%radius = radius
            call random_number(rand)
            new_disk%pos(1) = rand * (upper(1) - lower(1)) + lower(1)
            call random_number(rand)
            new_disk%pos(2) = rand * (upper(2) - lower(2)) + lower(2)

            collides = .false.
            do j=1, i-1
                if (overlaps(new_disk, disks(j), bc)) then
                    collides = .true.
                    exit
                end if
            end do
            if (.not. collides) then
                disks(i) = new_disk
                exit
            end if
        end do
    end do

    allocate(indices(num_disks))
    do i=1, num_disks
        indices(i) = i
    end do

    do t=1, 10000
        call print_disks(disks, num_disks)
        call shuffle(indices, num_disks)

        do i=1, num_disks
            idx = indices(i)

            new_disk = disks(idx)
            call random_number(rand)
            new_disk%pos(1) = new_disk%pos(1) + (rand * 2 - 1.0) * delta
            call random_number(rand)
            new_disk%pos(2) = new_disk%pos(2) + (rand * 2 - 1.0) * delta

            call restrict_position(new_disk%pos, bc)

            collides = .false.
            do j=1, num_disks
                if(j == idx) cycle

                if(overlaps(new_disk, disks(j), bc)) then
                    collides = .true.
                end if
            end do

            if(.not. collides) then
                disks(idx) = new_disk
            end if
        end do
    end do

    call print_disks(disks, num_disks)

    deallocate(seed)
    deallocate(indices)
    deallocate(disks)

    stop

contains

    subroutine print_disks(disks, n)
        type(disk) :: disks(:)
        integer, intent(in) :: n

        write(*,'(I0,/)') num_disks
        do i=1, num_disks
            write(*,'("H     ", f8.3, f8.3, " 0.0")') disks(i)%pos(1), disks(i)%pos(2)
        end do
    end subroutine print_disks

    ! Fisher-Yates-Durstenfeld shuffle algorithm
    subroutine shuffle(array, n)
        integer :: array(:)
        integer, intent(in) :: n
        integer :: i, j, tmp
        real    :: rnd

        do i=1, n-1
            call random_number(rnd)
            j = rnd * (n+1 - i) + i
            tmp = array(j)
            array(j) = array(i)
            array(i) = tmp
        end do
    end subroutine shuffle
end program main


!*==cgeqpf.f90  processed by SPAG 7.51RB at 20:37 on  3 Mar 2022
!> \brief \b CGEQPF
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download CGEQPF + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE CGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO )
!
!       .. Scalar Arguments ..
!       INTEGER            INFO, LDA, M, N
!       ..
!       .. Array Arguments ..
!       INTEGER            JPVT( * )
!       REAL               RWORK( * )
!       COMPLEX            A( LDA, * ), TAU( * ), WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> This routine is deprecated and has been replaced by routine CGEQP3.
!>
!> CGEQPF computes a QR factorization with column pivoting of a
!> complex M-by-N matrix A: A*P = Q*R.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>          The number of rows of the matrix A. M >= 0.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of columns of the matrix A. N >= 0
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is COMPLEX array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, the upper triangle of the array contains the
!>          min(M,N)-by-N upper triangular matrix R; the elements
!>          below the diagonal, together with the array TAU,
!>          represent the unitary matrix Q as a product of
!>          min(m,n) elementary reflectors.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,M).
!> \endverbatim
!>
!> \param[in,out] JPVT
!> \verbatim
!>          JPVT is INTEGER array, dimension (N)
!>          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
!>          to the front of A*P (a leading column); if JPVT(i) = 0,
!>          the i-th column of A is a free column.
!>          On exit, if JPVT(i) = k, then the i-th column of A*P
!>          was the k-th column of A.
!> \endverbatim
!>
!> \param[out] TAU
!> \verbatim
!>          TAU is COMPLEX array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is COMPLEX array, dimension (N)
!> \endverbatim
!>
!> \param[out] RWORK
!> \verbatim
!>          RWORK is REAL array, dimension (2*N)
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complexGEcomputational
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  The matrix Q is represented as a product of elementary reflectors
!>
!>     Q = H(1) H(2) . . . H(n)
!>
!>  Each H(i) has the form
!>
!>     H = I - tau * v * v**H
!>
!>  where tau is a complex scalar, and v is a complex vector with
!>  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).
!>
!>  The matrix P is represented in jpvt as follows: If
!>     jpvt(j) = i
!>  then the jth column of P is the ith canonical unit vector.
!>
!>  Partial column norm updating strategy modified by
!>    Z. Drmac and Z. Bujanovic, Dept. of Mathematics,
!>    University of Zagreb, Croatia.
!>  -- April 2011                                                      --
!>  For more details see LAPACK Working Note 176.
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE CGEQPF(M,N,A,Lda,Jpvt,Tau,Work,Rwork,Info)
      IMPLICIT NONE
!*--CGEQPF152
!
!  -- LAPACK computational routine (version 3.7.0) --
!  -- LAPACK 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 Info , Lda , M , N
!     ..
!     .. Array Arguments ..
      INTEGER Jpvt(*)
      REAL Rwork(*)
      COMPLEX A(Lda,*) , Tau(*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ZERO , ONE
      PARAMETER (ZERO=0.0E+0,ONE=1.0E+0)
!     ..
!     .. Local Scalars ..
      INTEGER i , itemp , j , ma , mn , pvt
      REAL temp , temp2 , tol3z
      COMPLEX aii
!     ..
!     .. External Subroutines ..
      EXTERNAL CGEQR2 , CLARF , CLARFG , CSWAP , CUNM2R , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , CMPLX , CONJG , MAX , MIN , SQRT
!     ..
!     .. External Functions ..
      INTEGER ISAMAX
      REAL SCNRM2 , SLAMCH
      EXTERNAL ISAMAX , SCNRM2 , SLAMCH
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      Info = 0
      IF ( M<0 ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ELSEIF ( Lda<MAX(1,M) ) THEN
         Info = -4
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('CGEQPF',-Info)
         RETURN
      ENDIF
!
      mn = MIN(M,N)
      tol3z = SQRT(SLAMCH('Epsilon'))
!
!     Move initial columns up front
!
      itemp = 1
      DO i = 1 , N
         IF ( Jpvt(i)/=0 ) THEN
            IF ( i/=itemp ) THEN
               CALL CSWAP(M,A(1,i),1,A(1,itemp),1)
               Jpvt(i) = Jpvt(itemp)
               Jpvt(itemp) = i
            ELSE
               Jpvt(i) = i
            ENDIF
            itemp = itemp + 1
         ELSE
            Jpvt(i) = i
         ENDIF
      ENDDO
      itemp = itemp - 1
!
!     Compute the QR factorization and update remaining columns
!
      IF ( itemp>0 ) THEN
         ma = MIN(itemp,M)
         CALL CGEQR2(M,ma,A,Lda,Tau,Work,Info)
         IF ( ma<N ) CALL CUNM2R('Left','Conjugate transpose',M,N-ma,ma,&
     &                           A,Lda,Tau,A(1,ma+1),Lda,Work,Info)
      ENDIF
!
      IF ( itemp<mn ) THEN
!
!        Initialize partial column norms. The first n elements of
!        work store the exact column norms.
!
         DO i = itemp + 1 , N
            Rwork(i) = SCNRM2(M-itemp,A(itemp+1,i),1)
            Rwork(N+i) = Rwork(i)
         ENDDO
!
!        Compute factorization
!
         DO i = itemp + 1 , mn
!
!           Determine ith pivot column and swap if necessary
!
            pvt = (i-1) + ISAMAX(N-i+1,Rwork(i),1)
!
            IF ( pvt/=i ) THEN
               CALL CSWAP(M,A(1,pvt),1,A(1,i),1)
               itemp = Jpvt(pvt)
               Jpvt(pvt) = Jpvt(i)
               Jpvt(i) = itemp
               Rwork(pvt) = Rwork(i)
               Rwork(N+pvt) = Rwork(N+i)
            ENDIF
!
!           Generate elementary reflector H(i)
!
            aii = A(i,i)
            CALL CLARFG(M-i+1,aii,A(MIN(i+1,M),i),1,Tau(i))
            A(i,i) = aii
!
            IF ( i<N ) THEN
!
!              Apply H(i) to A(i:m,i+1:n) from the left
!
               aii = A(i,i)
               A(i,i) = CMPLX(ONE)
               CALL CLARF('Left',M-i+1,N-i,A(i,i),1,CONJG(Tau(i)),      &
     &                    A(i,i+1),Lda,Work)
               A(i,i) = aii
            ENDIF
!
!           Update partial column norms
!
            DO j = i + 1 , N
               IF ( Rwork(j)/=ZERO ) THEN
!
!                 NOTE: The following 4 lines follow from the analysis in
!                 Lapack Working Note 176.
!
                  temp = ABS(A(i,j))/Rwork(j)
                  temp = MAX(ZERO,(ONE+temp)*(ONE-temp))
                  temp2 = temp*(Rwork(j)/Rwork(N+j))**2
                  IF ( temp2>tol3z ) THEN
                     Rwork(j) = Rwork(j)*SQRT(temp)
                  ELSEIF ( M>i ) THEN
                     Rwork(j) = SCNRM2(M-i,A(i+1,j),1)
                     Rwork(N+j) = Rwork(j)
                  ELSE
                     Rwork(j) = ZERO
                     Rwork(N+j) = ZERO
                  ENDIF
               ENDIF
            ENDDO
!
         ENDDO
      ENDIF
!
!     End of CGEQPF
!
      END SUBROUTINE CGEQPF


*> \brief \b DBDT02
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE DBDT02( M, N, B, LDB, C, LDC, U, LDU, WORK, RESID )
*
*       .. Scalar Arguments ..
*       INTEGER            LDB, LDC, LDU, M, N
*       DOUBLE PRECISION   RESID
*       ..
*       .. Array Arguments ..
*       DOUBLE PRECISION   B( LDB, * ), C( LDC, * ), U( LDU, * ),
*      $                   WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DBDT02 tests the change of basis C = U' * B by computing the residual
*>
*>    RESID = norm( B - U * C ) / ( max(m,n) * norm(B) * EPS ),
*>
*> where B and C are M by N matrices, U is an M by M orthogonal matrix,
*> and EPS is the machine precision.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrices B and C and the order of
*>          the matrix Q.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrices B and C.
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*>          B is DOUBLE PRECISION array, dimension (LDB,N)
*>          The m by n matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B.  LDB >= max(1,M).
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*>          C is DOUBLE PRECISION array, dimension (LDC,N)
*>          The m by n matrix C, assumed to contain U' * B.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*>          LDC is INTEGER
*>          The leading dimension of the array C.  LDC >= max(1,M).
*> \endverbatim
*>
*> \param[in] U
*> \verbatim
*>          U is DOUBLE PRECISION array, dimension (LDU,M)
*>          The m by m orthogonal matrix U.
*> \endverbatim
*>
*> \param[in] LDU
*> \verbatim
*>          LDU is INTEGER
*>          The leading dimension of the array U.  LDU >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is DOUBLE PRECISION array, dimension (M)
*> \endverbatim
*>
*> \param[out] RESID
*> \verbatim
*>          RESID is DOUBLE PRECISION
*>          RESID = norm( B - U * C ) / ( max(m,n) * norm(B) * EPS ),
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup double_eig
*
*  =====================================================================
      SUBROUTINE DBDT02( M, N, B, LDB, C, LDC, U, LDU, WORK, RESID )
*
*  -- LAPACK test routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      INTEGER            LDB, LDC, LDU, M, N
      DOUBLE PRECISION   RESID
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   B( LDB, * ), C( LDC, * ), U( LDU, * ),
     $                   WORK( * )
*     ..
*
* ======================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            J
      DOUBLE PRECISION   BNORM, EPS, REALMN
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DASUM, DLAMCH, DLANGE
      EXTERNAL           DASUM, DLAMCH, DLANGE
*     ..
*     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEMV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE, MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      RESID = ZERO
      IF( M.LE.0 .OR. N.LE.0 )
     $   RETURN
      REALMN = DBLE( MAX( M, N ) )
      EPS = DLAMCH( 'Precision' )
*
*     Compute norm( B - U * C )
*
      DO 10 J = 1, N
         CALL DCOPY( M, B( 1, J ), 1, WORK, 1 )
         CALL DGEMV( 'No transpose', M, M, -ONE, U, LDU, C( 1, J ), 1,
     $               ONE, WORK, 1 )
         RESID = MAX( RESID, DASUM( M, WORK, 1 ) )
   10 CONTINUE
*
*     Compute norm of B.
*
      BNORM = DLANGE( '1', M, N, B, LDB, WORK )
*
      IF( BNORM.LE.ZERO ) THEN
         IF( RESID.NE.ZERO )
     $      RESID = ONE / EPS
      ELSE
         IF( BNORM.GE.RESID ) THEN
            RESID = ( RESID / BNORM ) / ( REALMN*EPS )
         ELSE
            IF( BNORM.LT.ONE ) THEN
               RESID = ( MIN( RESID, REALMN*BNORM ) / BNORM ) /
     $                 ( REALMN*EPS )
            ELSE
               RESID = MIN( RESID / BNORM, REALMN ) / ( REALMN*EPS )
            END IF
         END IF
      END IF
      RETURN
*
*     End of DBDT02
*
      END


C
C $Id: curvd.f,v 1.5 2008-07-27 03:10:10 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
C NOTE: If you make any changes to this software, please remember to
C make the same changes to the corresponding double precision routine.
C
      function curvd (t,n,x,y,yp,sigma)
c
      integer n
      real t,x(n),y(n),yp(n),sigma
c
c                                 coded by alan kaylor cline
c                           from fitpack -- january 26, 1987
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function differentiates a curve at a given point
c using a spline under tension. the subroutine curv1 should
c be called earlier to determine certain necessary
c parameters.
c
c on input--
c
c   t contains a real value at which the derivative is to be
c   determined.
c
c   n contains the number of points which were specified to
c   determine the curve.
c
c   x and y are arrays containing the abscissae and
c   ordinates, respectively, of the specified points.
c
c   yp is an array of second derivative values of the curve
c   at the nodes.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters n, x, y, yp, and sigma should be input
c unaltered from the output of curv1.
c
c on output--
c
c   curvd contains the derivative value.
c
c none of the input parameters are altered.
c
c this function references package modules intrvl and
c snhcsh.
c
c-----------------------------------------------------------
c
c determine interval
c
      im1 = intrvl(t,x,n)
      i = im1+1
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n-1)/(x(n)-x(1))
c
c set up and perform differentiation
c
      del1 = t-x(im1)
      del2 = x(i)-t
      dels = x(i)-x(im1)
      sum = (y(i)-y(im1))/dels
      if (sigmap .ne. 0.) go to 1
      curvd = sum+(yp(i)*(2.*del1*del1-del2*(del1+dels))-
     *             yp(im1)*(2.*del2*del2-del1*(del2+dels)))
     *             /(6.*dels)
      return
    1 sigdel = sigmap*dels
      call snhcsh (ss,dummy,sigdel,-1)
      call snhcsh (dummy,c1,sigmap*del1,1)
      call snhcsh (dummy,c2,sigmap*del2,1)
      curvd = sum+(yp(i)*(c1-ss)-yp(im1)*(c2-ss))/
     *        (sigdel*sigmap*(1.+ss))
      return
      end


      INCLUDE 'VICMAIN_FOR'
      SUBROUTINE MAIN44
C
C  VICAR Program FFT1PIX
C
C	FFT1PIX  is  a  VICAR application program which works in conjunction
C	with  FFT1  to  allow  the user to display and/or modify the Fourier
C	transform  using  existing VICAR programs.  The procedure is similar
C	to  that  used  in  FFT2,  FFTPIC,  and  TPIKMASK  but  without  the
C	restriction  that  terms  of  the transform be either set to zero or
C	left  unchanged.   In  the forward mode, the input to fft1pix is the
C	complex Fourier transform from FFT1.  The output can be an amplitude
C	picture  and/or a phase picture of the transform.  Those can then be
C	modified to the users needs and re-inputed to fft1pix in the reverse
C	mode.   The  Fourier transform is then modified in accordance to the
C	changes made to the amplitude and/or phase pictures.
C
C  WRITTEN BY:	 		JOHN ADDINGTON
C  COGNIZANT PROGRAMMER: 	FLORANCE MOSS
C  REVISION: 			04 JAN 1993
C  CONVERTED TO VAX BY:  	F. F. Moss,    20 JAN 1984
C  CONVERTED TO VICAR2 BY:  	D. F. Stanfill,   JUN 1987
C  PORTED BY:			J. F. McNeill, 04 JAN 1993
C
C  5  JAN 77   	...JDA...   INITIAL RELEASE
C  28 SEP 87   	...FFM...   DELETED AN ADDITIONAL XVOPEN CALL
C               	    ADDED XVCLOSE CALLS
C                           MODIFIED CODE TO HANDLE NUMBER OF SAMPLES CORRECTLY
C                           CHANGED PARAM "TYPE" DEFAULT TO AMPL
C                           MODIFIED THE COUNT NUMBER FOR PARAM "PLOT"
C                           UPDATED TEST PDF
C  04 SEP 90 	...LWK...   fixed so 'PLOT' does not disable amplitude output, &
C		            XVOPEN(OUT..) is not called if no output specified.
C  04 JAN 93	...JFM...   Ported to UNIX and removed OUTCON and BINBCD calls.
C  08 FEB 93	...JFM...   Compilation warnings avoided by revision of COMMON
C			    block declarations in subroutines SAVAGE, KEEPIT,
C			    and AVGIT.
C
      IMPLICIT INTEGER (A-Z)

      BYTE BUF(2048),PBUF(2048)
      INTEGER IPLOT(20), CNT

      REAL DC,GAIN,A,SCALE,AREF,TOP,MAX,DIF,ERR,AR,CON
      REAL RC,AIC,THETA,FREQNM,MIN,PSCALE
      REAL AA(2048),AAVG(512),KEPBUF(512,10),P(512,2)

      LOGICAL REVERS,LOG,CONJ,NORMAL,PLOT,FREQ,PHASE,AMPL,NOSIGN,ZERO
      LOGICAL XVPTST
      COMPLEX C(2048),CC(2048),CZERO

      CHARACTER*4  LWD
      CHARACTER*8  XHD,XHD1,XHD2,YHD
      CHARACTER*32 PR1
      CHARACTER*69 AMPBUF,PHSBUF
      CHARACTER*80 HD

      EQUIVALENCE (BUF(1),PBUF(1))
      EQUIVALENCE (C(1),CC(1))
      COMMON /C1/ AA,KEPBUF,AAVG,P

      INCLUDE 'fortport'
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C     ** PARAMETERS **
C
C        FORWARD MODE  (DEFAULT)
C        AMPLITUDE PICTURE  (DEFAULT)
C     'LOG'         OUTPUT IS THE NATR'L LOGRITHM OF AMPLITUDE PICTURE.
C     'SPIKE',I     EACH LINE NORMALIZED TO I'TH PEAK (DEFAULT=DC SPIKE)
C     'NORMAL'      OUTPUT NORMALIZED TO FIRST LINE.
C     'PLOT',N,M... PAGE PLOT AMPLITUDES OF LINES N,M,... (MAX=20)
C     'FREQ'        FREQUENCY GIVEN AS X-AXIS OF PAGE PLOT.
C                                      (DEFAULT=TERM NUMBER)
C     'AVG',I       PAGE PLOT OF LINE IS THE AVERAGE OF THE PRECEEDING
C                                      I LINES.  (MAX=10)
C     'PSPIKE',I    PAGE PLOT NORMALIZED TO I'TH PEAK.
C     'CONJ'        COMPLEX CONJUGATE ALSO OUTPUTED.
C
C        PHASE PICTURE
C     'PHASE'       PHASE PICTURE OUTPUTED.
C     'NOSIGN'      SIGN OF PHASE ANGLE DISREGUARDED IN PHASE PICTURE.
C
C
C        REVERSE MODE
C     'REVERSE'     REVERSE MODE
C     'LOG'         OPTION USED IN FORWARD MODE
C     'SPIKE',I     OPTION USED IN FORWARD MODE
C     'NORMAL'      OPTION USED IN FORWARD MODE
C     'PLOT',N,M... PAGE PLOTS OF AMPLITUDES AFTER MODIFICATION.
C     'AVG',I       SAME AS IN FORWARD MODE.
C     'PSPIKE',I    SAME AS IN FORWARD MODE.
C     'FREQ'        SAME AS IN FORWARD MODE.
C     'CONJ'        NOT NORMALLY USED IN REVERSE MODE.  IF USED IT
C                       DENOTES THAT CONJUGATE IS MODIFIED DIFFERENTLY.
C     'DC',R        (DECIMAL)  DC LEVEL INCREASED BY R.
C     'GAIN',R      (DECIMAL)  GAIN INCREASED BY A FACTOR OF R.
C     'ZERO'        ZERO IN REFERENCE CAUSES COMPLEX TERM TO BE ZEROED
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C
C        DEFAULT PARAMETERS
      ZERO= .FALSE.
      CZERO= CMPLX(0.0,0.0)

C        OPEN INPUT DATA SET
      CALL XVUNIT( IUN, 'INP', 1, ISTAT,' ')
      CALL XVOPEN( IUN, ISTAT, 'OPEN_ACT', 'SA', 'IO_ACT', 'SA',' ')
      CALL XVSIZE( SL, SS, NL, NS, NLI, NSI)
      NS=NS*8
      CALL XVPCNT('INP', NI)
      CALL XVPCNT('OUT', NO)
C        GET PARAMETERS
      CALL XVP('DC', DC, CNT)
      CALL XVP('GAIN', GAIN, CNT)
      REVERS = XVPTST('REVERSE')
      LOG = XVPTST('LOG')
      CONJ = XVPTST('CONJ')
      CALL XVP('SPIKE',SPIKE,CNT)
      NORMAL = XVPTST('NORMAL')
      CALL XVP('PLOT', IPLOT, NPLOT)
      PLOT = NPLOT .NE. 0
      CALL XVP('AVG', NAVE, CNT)
      FREQ = XVPTST('FREQ')
      CALL XVP('PSPIKE', PSPIKE, CNT)
      PHASE = XVPTST('PHASE') .AND. NO.GT.0
      NOSIGN = XVPTST('NOSIGN')
      AMPL = XVPTST('AMPL') .AND. NO.GT.0
      ZERO = XVPTST('ZERO')

C     INITIALIZE STRINGS

      AMPBUF	= ' '
      PHSBUF	= ' '
      HD 	= ' '
      LWD	= ' '
      XHD1 	= '    TERM'
      XHD2 	= '    FREQ'
      YHD 	= '  AMP   '

      IF(NAVE.GT.10)  NAVE= 10
      DC= DC*NS
      XCODE= 0
      XHD = XHD1
      IF(.NOT.FREQ)  GO TO 110
      XCODE= 3
      XHD = XHD2
110   CONTINUE
      NSF= NS/8
      FREQNM= 1./NSF
C
      IF(NI.GT.1 .AND. REVERS)   GO TO 600
C
C     ***** FORWARD MODE *****
C
      IF (PHASE .AND. NO.LE.1)  AMPL= .FALSE.
      NSA= NS
      NB= NSA/16+1
      IF (CONJ) NB = NSA/8
      NLO= NL
C
C        SET UP LABEL MODIFICATION BUFFERS
      PTR= 1
      IF(.NOT.AMPL)  GO TO 135
      IF(.NOT.LOG)  GO TO 120
      AMPBUF(PTR:PTR+3) = 'LOG '
      PTR=PTR+4
120   AMPBUF(PTR:PTR+9) = 'AMPLITUDE '
      PTR=PTR+10
      IF(.NOT.NORMAL)  GO TO 125
      AMPBUF(PTR:PTR+6) = 'NORMAL '
      PTR= PTR+7
125   IF(SPIKE.LE.0)  GO TO 135
      AMPBUF(PTR:PTR+5) = 'SPIKE '
      PTR= PTR+6
      WRITE (LWD,130) SPIKE
130   FORMAT (I4)
      AMPBUF(PTR:PTR+1) = LWD(3:4)
      PTR = PTR+2
135   IF(.NOT.PHASE)  GO TO 145
      PTR= 1
      PHSBUF(PTR:PTR+5) = 'PHASE '
      PTR= PTR+6
      IF(.NOT.NOSIGN)  GO TO 145
      PHSBUF(PTR:PTR+6) = 'NOSIGN '
      PTR = PTR+7
145   CONTINUE
C
C
C   RELABEL OUTPUT
      PDS = 1
      IF (AMPL) THEN
	CALL XVUNIT( OUN, 'OUT', 1, ISTAT, ' ')
	CALL XVOPEN( OUN, ISTAT, 'OPEN_ACT', 'SA', 'IO_ACT', 'SA',
     .	 'OP', 'WRITE', 'O_FORMAT', 'BYTE', 'U_FORMAT', 'BYTE',
     .	 'U_NL', NLO, 'U_NS', NB, ' ')
	CALL XLADD( OUN, 'HISTORY', 'PGM_LAB', AMPBUF, ISTAT, 'ULEN',
     .	 PTR, 'FORMAT', 'STRING', ' ')
	PDS = 2
      ENDIF
      IF (PHASE) THEN
	CALL XVUNIT( PUN, 'OUT', PDS, ISTAT, ' ')
	CALL XVOPEN( PUN, ISTAT, 'OPEN_ACT', 'SA', 'IO_ACT', 'SA',
     .	 'OP', 'WRITE', 'O_FORMAT', 'BYTE', 'U_FORMAT', 'BYTE',
     .	 'U_NL', NLO, 'U_NS', NB, ' ')
	CALL XLADD( PUN, 'HISTORY', 'PGM_LAB', PHSBUF, ISTAT, 'ULEN',
     .	 PTR, 'FORMAT', 'STRING', ' ')
      ENDIF
      IF (AMPL .OR. PHASE) THEN
        WRITE (PR1,160) NLO, NB
160     FORMAT ('** OUTPUT  NL=',I4,'   NS=',I4,' **')
	CALL XVMESSAGE(PR1,' ')
	CALL XVMESSAGE(' ',' ')
      ENDIF
      LINE2= SL
      SLN= SL-1
      SLN2= SL
      SLN3= SL+1
      NPPTS= NB
      IF(NPPTS.GT.512)  NPPTS= 512
      IF(PLOT) CALL SAVAGE(N,NAVE,NSR,NPPTS)
      KPLOT= 1
      N= 0
C
C
C        MAIN LOOP (FORWARD)
C
      DO 500 II=1,NLO
      CALL XVREAD( IUN, C, ISTAT, ' ')
      LINE2= 0
C
C        COMPUTE AMPLITUDES
C
      IF(.NOT.AMPL .AND. .NOT.PLOT)  GO TO 1200
      DO 210 J=1,NB
210   AA(J)= CABS(C(J))
C
C        MAKE PAGE PLOT (IF DESIRED)
C
      IF(.NOT.PLOT)  GO TO 250
      CALL KEEPIT(N,NAVE,NSR,NHOLD)
      IF(IPLOT(KPLOT).NE.II+SL-1)  GO TO 250
      CALL AVGIT(NHOLD,NPPTS)
      DO 215 J=1,NPPTS
      P(J,1)= J
      IF(FREQ)  P(J,1)= (J-1)*FREQNM
215   P(J,2)= AAVG(J)
      NUMBER = IPLOT(KPLOT)
      WRITE (HD, 225) NUMBER, NAVE
225   FORMAT ('1-D FOURIER TRANSFORM    LINE ',I4,'    AVERAGE',I2)
      CALL PPLOT(P,512, NPPTS,PSPIKE,HD,XHD,YHD,XCODE,-6)
      KPLOT= KPLOT+1
      IF(KPLOT.GT.NPLOT)  PLOT= .FALSE.
C
250   IF(NO.EQ.0)  GO TO 500
      IF(NORMAL .AND. II.NE.1)  GO TO 290
      TOP= AA(1)
      IF(SPIKE.EQ.0)  GO TO 280
C
C        FIND DESIRED SPIKE
C
      TOP= 9.9E30
      DO 270 K=1,SPIKE
        MAX= 0.0
        DO 260 J=1,NB
          IF(AA(J).LE.MAX .OR. AA(J).GE.TOP)  GO TO 260
          MAX= AA(J)
260     CONTINUE
270   TOP= MAX
C
280   IF(LOG .AND. TOP.GT.0.)  TOP= ALOG(TOP)
      IF(TOP.LE.0.)  TOP= 1.
      SCALE= 255./TOP
C
C        SCALE AMPLITUDES
C
290   DO 300 J=1,NB
      A= AA(J)
      IF(LOG .AND. A.GT.0.)  A= ALOG(A)
      IA= A*SCALE + 0.5
      IF(IA.GT.255)  IA= 255
      IF(IA.LT.0)  IA= 0
300   BUF(J) = INT2BYTE(IA)
C
C
      CALL XVWRIT( OUN, BUF, ISTAT, ' ')
C
C        COMPUTE PHASE ANGLES
C
1200  IF(.NOT.PHASE)  GO TO 500
      DO 1210 J=1,NB
      CALL PHASER(C(J),RC,AIC,AA(J))
      IF(NOSIGN)  AA(J)= ABS(AA(J))
1210  CONTINUE
C
C        COMPUTE SCALE FACTOR
C
      MAX= -9.9E30
      MIN= 9.9E30
      DO 1260 J=1,NB
      A= AA(J)
      IF(A.GT.MAX)  MAX= A
      IF(A.LT.MIN)  MIN= A
1260  CONTINUE
      IF(MAX.NE.MIN)  GO TO 1261
      PSCALE=0.
      GO TO 1262
1261  PSCALE= 255./(MAX-MIN)
1262  CONTINUE
C
C        SCALE PHASE ANGLES
C
      DO 1300 J=1,NB
      IA= PSCALE*(AA(J)-MIN) + 0.5
1300  PBUF(J) = INT2BYTE(IA)
C
      CALL XVWRIT( PUN, PBUF, ISTAT, ' ')
C
C
500   CONTINUE
      CALL XVCLOSE (IUN,ISTAT,' ')
      IF (AMPL)  CALL XVCLOSE (OUN,ISTAT,' ')
      IF (PHASE) CALL XVCLOSE (PUN,ISTAT,' ')
C
      RETURN
C
C
C     ***** REVERSE MODE *****
C
600   CONTINUE
C
      NSA= NS
      NLI= NL
      NB= NSA/8
      NBR= NSA/16+1
      IF(CONJ)  NBR= NB
      NBT= NBR*2
C
C        OPEN DATA SETS
C
      PDS= 3
      IF (NI.GT.1)  AMPL= .TRUE.
      IF (PHASE .AND. NI.LE.2) THEN
	AMPL= .FALSE.
	PDS= 2
      ENDIF
      IF (AMPL) THEN
	CALL XVUNIT( AUN, 'INP', 2, ISTAT, ' ')
	CALL XVOPEN( AUN, ISTAT, 'OPEN_ACT', 'SA', 'IO_ACT', 'SA', ' ')
      ENDIF
      IF (PHASE) THEN
	CALL XVUNIT( PUN, 'INP', PDS, ISTAT, ' ')
	CALL XVOPEN( PUN, ISTAT, 'OPEN_ACT', 'SA', 'IO_ACT', 'SA', ' ')
      ENDIF
      CALL XVUNIT( OUN, 'OUT', 1, ISTAT, ' ')
      CALL XVOPEN( OUN, ISTAT, 'OPEN_ACT', 'SA', 'IO_ACT', 'SA',
     . 'OP', 'WRITE', 'U_FORMAT','COMP','O_FORMAT','COMP',' ')
      LINE2= SL
      LINE3= SL
      LINEP= SL
      SLN= SL-1
      NPPTS= NBR
      IF(NPPTS.GT.512)  NPPTS= 512
      KPLOT= 1
      N= 0
C
C
C        MAIN LOOP (REVERSE)
C
      DO 880 II=1,NLI
      CALL XVREAD( IUN, C, ISTAT, ' ')
      IF (AMPL) CALL XVREAD( AUN, BUF ,ISTAT, ' ')
      LINE2= 0
      LINE3= 0
C
      IF(.NOT.AMPL)  GO TO 1600
C
C        COMPUTE AMPLITUDES
C
615   DO 620 J=1,NB
620   AA(J)= CABS(C(J))
C
C        FIND DESIRED SPIKE
C
      IF(NORMAL .AND. II.NE.1)  GO TO 690
      TOP= AA(1)
      IF(SPIKE.EQ.0)  GO TO 680
      TOP= 9.9E30
      DO 640 K=1,SPIKE
      MAX= 0.0
      DO 630 J=1,NBR
      IF(AA(J).LE.MAX .OR. AA(J).GE.TOP)  GO TO 630
      MAX= AA(J)
630   CONTINUE
640   TOP= MAX
C
C        COMPUTE ERROR EXPECTED,  SET DC LEVEL
C
680   IF(LOG .AND. TOP.GT.0.)  TOP= ALOG(TOP)
      SCALE= TOP/255.
      ERR= 0.5*SCALE
690   CC(1)= C(1)
      IF(DC.EQ.0.0)  GO TO 695
      CALL PHASER(C(1),RC,AIC,THETA)
      AR= AA(1)+DC
      RC= AR*COS(THETA)
      AIC= AR*SIN(THETA)
      CC(1)= CMPLX(RC,AIC)
695   CONTINUE
C
C        MODIFY AMPLITUDES OF COMPLEX PICTURE
C
      DO 800 J=2,NBR
      CC(J)= C(J)*GAIN
      IF(.NOT.CONJ)  CC(NBT-J)= C(NBT-J)*GAIN
      IA = BYTE2INT(BUF(J))
      IF(IA.GE.255)  GO TO 800
      IF(.NOT.ZERO .OR. IA.GT.0)  GO TO 700
      CC(J)= CZERO
      IF(.NOT.CONJ .AND. J.NE.NBR)  CC(NBT-J)= CZERO
      GO TO 800
700   AREF= IA*SCALE
      A= AA(J)
      IF(LOG .AND. A.GT.0.)  A= ALOG(A)
      DIF= ABS(A-AREF)
      IF(DIF.LE.ERR)  GO TO 800
      IF(A .LT. 1.E-25)  GO TO 800
      AREF= AREF/A
750   CC(J)= CC(J)*AREF
      IF(CONJ .OR. J.EQ.NBR)  GO TO 800
      CC(NBT-J)= CC(NBT-J)*AREF
800   CONTINUE
C
C        MAKE PAGE PLOT (IF DESIRED)
C
      IF(.NOT.PLOT)  GO TO 850
      DO 810 J=1,NPPTS
810   AA(J)= CABS(CC(J))
      CALL KEEPIT(N,NAVE,NSR,NHOLD)
      IF(IPLOT(KPLOT).NE.II+SL-1)  GO TO 875
      CALL AVGIT(NHOLD,NPPTS)
      DO 815 J=1,NPPTS
      P(J,1)= J
      IF(FREQ)  P(J,1)= (J-1)*FREQNM
815   P(J,2)= AAVG(J)
      NUMBER = IPLOT(KPLOT)
      WRITE (HD,825) NUMBER, NAVE
825   FORMAT ('1-D FOURIER TRANSFORM    LINE ',I4,'    AVERAGE',I2)
      CALL PPLOT(P,512, NPPTS,PSPIKE,HD,XHD,YHD,XCODE,-6)
      KPLOT= KPLOT+1
      IF(KPLOT.GT.NPLOT)  PLOT= .FALSE.
850   CONTINUE
C
C        COMPUTE PHASE ANGLES
C
1600  IF(.NOT.PHASE)  GO TO 875
      CALL XVREAD( PUN, PBUF, ISTAT, ' ')
      LINEP= 0
      DO 1610 J=1,NB
      CALL PHASER(C(J),RC,AIC,AA(J))
      IF(NOSIGN)  AA(J)= ABS(AA(J))
1610  CONTINUE
C
C        COMPUTE SCALE FACTOR
C
      MAX= -9.9E30
      MIN= 9.9E30
      DO 1660 J=1,NB
      A= AA(J)
      IF(A.GT.MAX)  MAX= A
      IF(A.LT.MIN)  MIN= A
1660  CONTINUE
      PSCALE= (MAX-MIN)/255.
      ERR= 0.5*PSCALE
C
C        MODIFY PHASE ANGLES OF COMPLEX PICTURE
C
      DO 1700 J=2,NBR
      IA = BYTE2INT(PBUF(J))
      AREF= IA*PSCALE+MIN
      A= AA(J)
      DIF= ABS(A-AREF)
      IF(DIF.LT.ERR)  GO TO 1700
      CON= TAN(AREF)
      CON= CON*CON
      A= CABS(CC(J))
      RC= A/SQRT(1.+CON)
      CON= 1./CON
      AIC= A/SQRT(1.+CON)
      CC(J)= CMPLX(RC,AIC)
      IF(CONJ .OR. J.EQ.NBR)  GO TO 1700
      CC(NBT-J)= CONJG(CC(J))
1700  CONTINUE
C
C
875   CALL XVWRIT( OUN, CC, ISTAT, ' ')
880   CONTINUE
      CALL XVCLOSE (IUN,ISTAT,' ')
      CALL XVCLOSE (OUN,ISTAT,' ')
      IF (AMPL)  CALL XVCLOSE(AUN,ISTAT,' ')
      IF (PHASE) CALL XVCLOSE(PUN,ISTAT,' ')
C
      RETURN
      END

      SUBROUTINE PHASER(C,RE,AIMG,THETA)
      COMPLEX C
C
      RE= REAL(C)
      AIMG= AIMAG(C)
      IF(RE.EQ.0.0)  GO TO 10
      THETA= ATAN2(AIMG,RE)
      GO TO 30
10    IF(AIMG.EQ.0.0)  GO TO 20
      THETA= SIGN(1.570796,AIMG)
      GO TO 30
20    THETA= 0.0
30    RETURN
      END

      SUBROUTINE PPLOT(P,N,NPTS,SAT,TITLE,XAXIS,YAXIS,XCODE,YCODE)
C
      IMPLICIT INTEGER (A-Z)

      CHARACTER*1 	ONE,ZERO,BLANK
      CHARACTER*4	NUM
      CHARACTER*8 	XAXIS,YAXIS
      CHARACTER*32 	HMAX
      CHARACTER*80   	TITLE
      CHARACTER*101     RASTER
      CHARACTER*132 	LINE

      REAL P(1),RNUM,MAX,ZMAX,PCENT,LARGE/9.9E 15/
C
C        CODE .LT. 0    FLOATING POINT  9-CODE FRACTION DIGITS
C        CODE .EQ. 0    INTEGER
C        CODE .GT. 0    FIXED POINT  CODE FRACTION DIGITS

C     INITIALIZE CHARACTER STRINGS

      ONE	= '1'
      ZERO 	= '0'
      BLANK 	= ' '
      RASTER	= ' '
      LINE 	= ' '
      HMAX	= ' '

C     PAGE ADVANCE
      CALL QPRINT(ONE,1)

      CALL XVMESSAGE(TITLE,' ')
      CALL XVMESSAGE(' ',' ')

      ZMAX= LARGE
      DO 110 K=1,SAT
      MAX= 0.0
      DO 100 J=1,NPTS
      IF(P(N+J).LE.MAX .OR. P(N+J).GE.ZMAX)  GO TO 100
      MAX= P(N+J)
100   CONTINUE
      ZMAX= MAX
110   CONTINUE
      IF(MAX.LT.1.0E-20)  MAX= 1.
C
C
      IF(YCODE.LT.0) THEN
	WRITE (HMAX, 115) MAX
115	FORMAT (9X,E8.3,' = 100 PERCENT')
      ENDIF

      IF(YCODE.EQ.0) THEN
	WRITE (HMAX, 120) MAX
120	FORMAT (9X,I8,' = 100 PERCENT')
      ENDIF

      IF(YCODE.GT.0) THEN
	WRITE (HMAX, 125) MAX
125	FORMAT (9X,F8.3,' = 100 PERCENT')
      ENDIF
      CALL XVMESSAGE(HMAX,' ')
      CALL XVMESSAGE(' ',' ')

      LINE(1:8)  	= XAXIS
      LINE(11:18) 	= YAXIS
      LINE(22:28)	= 'PERCENT'
      LINE(31:31)	= ZERO
      PTR = 38
      DO 200 J=10,100,10

      WRITE (NUM, 150) J
150   FORMAT (I4)
      LINE(PTR:PTR+3) = NUM
200   PTR= PTR+10

      CALL XVMESSAGE(LINE,' ')
C
C        PLOT
C

C     Reinitialize string

      MAX = 1./MAX

      DO 500 J = 1,NPTS

      LINE = ' '

      PCENT = 100.*P(N+J)*MAX +0.0005
      QCENT = PCENT+0.5
      IF(QCENT.GT.100) 	QCENT=100
      IF(QCENT.LT.0) 	QCENT=0

      IF(XCODE.LT.0)  THEN
	WRITE (LINE(1:8), 210) P(J)
210	FORMAT (E8.3)
      ENDIF

      IF(XCODE.EQ.0)  THEN
	PNUM = P(J)
	WRITE (LINE(1:8), 215) PNUM
215	FORMAT (I8)
      ENDIF

      IF(XCODE.GT.0)  THEN
	WRITE (LINE(1:8), 220) P(J)
220	FORMAT (F8.3)
      ENDIF

      IF(YCODE.LT.0)  THEN
	RNUM = P(N+J)
	WRITE (LINE(11:20), 230) RNUM
230	FORMAT (E8.3)
      ENDIF

      IF(YCODE.EQ.0)  THEN
	PNUM = P(N+J)
	WRITE (LINE(11:20), 235) PNUM
235	FORMAT (I9)
      ENDIF

      IF(YCODE.GT.0)  THEN
	WRITE (LINE(11:20), 240) P(N+J)
240	FORMAT (F8.3)
      ENDIF

      WRITE (LINE(21:29), 250) PCENT
250   FORMAT (F8.3)

      PTR = 31
      DO 400  K=1,11
      LINE(PTR:PTR) = '+'
      PTR=PTR+10
400   CONTINUE

      PTR = 31
      DO 450  K=1,QCENT+1
      LINE(PTR:PTR) = '*'
450   PTR=PTR+1

      CALL XVMESSAGE(LINE,' ')

500   CONTINUE
C
      RETURN
      END

      SUBROUTINE SAVAGE(N,NAVE,NSR,NSI)
      IMPLICIT INTEGER (A-Z)

      N = 0
      NSR = NSI * 4
      RETURN
      END

      SUBROUTINE KEEPIT(N,NAVE,NSR,NHOLD)
      IMPLICIT INTEGER (A-Z)
      REAL AA(2048),AAVG(512),KEPBUF(512,10),P(512,2)
      COMMON /C1/ AA,KEPBUF,AAVG,P

      N= N+1
      NV= MOD(N,NAVE)
      IF(NV.EQ.0)  NV= NAVE
      NHOLD= NV
      IF(N.GE.NAVE)  NHOLD= NAVE
      DO 50 K=1,NSR
50    KEPBUF(K,NV) = AA(K)
      RETURN
      END
C
      SUBROUTINE AVGIT(NHOLD,NSI)
      IMPLICIT INTEGER (A-Z)
      REAL AA(2048),AAVG(512),KEPBUF(512,10),P(512,2),RHOLD,TOT
      COMMON /C1/ AA,KEPBUF,AAVG,P

      RHOLD= NHOLD
      RHOLD= 1./RHOLD
      DO 175 J=1,NSI
      TOT= 0.0
      DO 150 I=1,NHOLD
150   TOT= TOT + KEPBUF(J,I)
      AAVG(J)= TOT*RHOLD
175   CONTINUE
      RETURN
      END


program ising

use subroutines
use rm
implicit none

	integer,parameter::L=20,T_max = 500,promedio=25
	integer::posx,posy,dim
	integer:: i,j,k
	integer::Delta_E
	integer::matriz(L,L)
	real::rvec(1)
	real::prom,prom_M2,prom_M4,Temp,mag(promedio),m2(promedio),m4(promedio),DeltaE(2),U4
	real::suceptibility,cap_calorifica
	real::energ(promedio),prom_energia,energ2(promedio),prom_energia2
	real::T_inicial
	character(len=25)::filename='magnetization30L.dat'
	dim = L*L
	T_inicial=0
	Temp = T_inicial

	open (UNIT=1, FILE=filename,ACTION='write',STATUS='replace')
	close(1)

	do j = 1,T_max !T_max no es una temperatura sino un parámetro que mide el numero de temperaturas intermedias que se miden

		call variables_a_cero(promedio,mag,m2,m4,energ,energ2,prom,prom_M2,prom_M4,prom_energia,prom_energia2,u4)

		call Inicializacion_DeltaE(DeltaE,Temp)

		do k = 1, promedio

			!Inicializamos la matriz
			!Dandole estados iniciales up a los espines del problema
			call ini_matriz(matriz,L)

			!Elegimos un (posx,posy) aleatorio donde empieza a recorrer los espines
			call elegir_sitio(L,posx,posy)

			!Sumatoria que se realiza en un tiempo de Monte Carlo //dim = 1MC
			do i=1,200*dim
				!Calculamos el delta de energia
				call calc_delta_energia(L,posx,posy,matriz,Delta_E)
				call ranmar(rvec,1)
				select case (Delta_E)
					case (-8)
						matriz(posx,posy) = - matriz(posx,posy)
					case (-4)
						matriz(posx,posy) = - matriz(posx,posy)
					case (4)
						if( DeltaE(1) > rvec(1)) then
							matriz(posx,posy) = - matriz(posx,posy)
						end if
					case (8)
						if( DeltaE(2) > rvec(1) ) then
							matriz(posx,posy) = - matriz(posx,posy)
						end if
				end select

				!call nuevo_paso(posx,posy)
				call elegir_sitio(L,posx,posy)
			end do

			!Luego de los pasos montecarlo, calculamos la magnetizacion
			call magnetizacion (L,matriz,mag,M2,M4,energ,energ2,promedio,k,Delta_E)

		end do

		call promediar(promedio,mag,m2,m4,energ,energ2,prom,prom_M2,prom_M4,prom_energia,prom_energia2,u4)
		call funciones_especiales(prom,prom_energia,prom_energia2,prom_M2,Temp,suceptibility,cap_calorifica)
		call escritura(filename,dim,Temp,prom,prom_M2,prom_M4,prom_energia,suceptibility,cap_calorifica,prom_energia2)
		call aumento_temp(j,Temp,T_inicial)
	end do

end program ising


SUBROUTINE MGRestriction3DExplicit(PHIfine,PHIcoarse,FineGrid,CoarseGrid,GhostGridX,GhostGridY,GhostGridZ,Nzf,Nxf,Nyf,Nzc,Nxc,Nyc)
! By Allan P. Engsig-Karup.
USE Precision
USE Constants
USE DataTypes
IMPLICIT NONE
REAL(KIND=long), DIMENSION(:,:), POINTER :: xf,yf
REAL(KIND=long), DIMENSION(:), POINTER :: zf
TYPE (Level_def) :: FineGrid, CoarseGrid ! Grid information
INTEGER :: xcoarsen, ycoarsen, zcoarsen, GhostGridX,GhostGridY, GhostGridZ
INTEGER :: Nxf, Nyf, Nzf, Nxc, Nyc, Nzc, N, NS
REAL(KIND=long), DIMENSION(Nzf,Nxf,Nyf) :: PHIfine, tmp3D
REAL(KIND=long), DIMENSION(Nzc,Nxc,Nyc) :: PHIcoarse
INTEGER :: kc,jc,ic
INTEGER :: ifine, jfine, kfine
REAL(KIND=long) :: dx_W, dx_E, dy_S, dy_N, dz_D, dz_U, dxc, dyc, dzc

! Initialize output array
PHIcoarse = zero
tmp3D     = PHIfine

! USE POINTERS TO ALREADY ALLOCATED GRID VECTORS
xf => FineGrid%x;   yf => FineGrid%y;   zf => FineGrid%z

! coarsenig strategi is based on the physical grid sizes
Nxf = Nxf-2*GhostGridX
Nxc = Nxc-2*GhostGridX
Nyf = Nyf-2*GhostGridY
Nyc = Nyc-2*GhostGridY
Nzf = Nzf-GhostGridZ
Nzc = Nzc-GhostGridZ

! Determine coarsening strategy for each dimension
xcoarsen = 0; ycoarsen = 0; zcoarsen = 0
IF (Nxf>Nxc) THEN; xcoarsen = 1; ENDIF
IF (Nyf>Nyc) THEN; ycoarsen = 1; ENDIF
IF (Nzf>Nzc) THEN; zcoarsen = 1; ENDIF

! *******************************************
!			 X-COARSEN
! *******************************************

IF (xcoarsen==1) THEN
!  print*,'X-coarsen'
    IF (GhostGridX==1) THEN
        ! We have Ghost Layers present
        ! OMIT Ghost Point Layer's from restriction

	! interior points, full stencil
	DO ifine = 1+GhostGridX , Nxf+GhostGridX, 2
		dx_W = xf(ifine,1+GhostGridY) - xf(ifine-1,1+GhostGridY) ! FIXME: y-index
		dx_E = xf(ifine+1,1+GhostGridY) - xf(ifine,1+GhostGridY) ! FIXME: y-index
!        print*,'dx_W=',dx_W
!        print*,'dx_E=',dx_E
		dxc  = one/(dx_W + dx_E)
		DO kfine = 1+GhostGridZ , Nzf+GhostGridZ-1 ! FREE SURFACE LAYER NOT INCLUDED SINCE THERE WE USE DIRECT INJECTION
			DO jfine = 1+GhostGridY , Nyf+GhostGridY
				tmp3D(kfine,ifine,jfine) = (half*dxc)*(dx_W*tmp3D(kfine,ifine-1,jfine) + (dx_W+dx_E)*tmp3D(kfine,ifine,jfine) + &
				   dx_E*tmp3D(kfine,ifine+1,jfine))
			END DO
		END DO
	END DO
    ELSE
       WRITE (*,'(A)') 'Error: currently multigrid has not been implemented for grid without a single ghost layer.'
       STOP ! FORCED STOP
    ENDIF
ENDIF

! *******************************************
!			 Y-COARSEN
! *******************************************

IF (ycoarsen==1) THEN
!  print*,'Y-coarsen'
    IF (GhostGridY==1) THEN
        ! We have Ghost Layers present
        ! OMIT Ghost Point Layer's from restriction

	! interior points, full stencil
	DO jfine = 1+GhostGridY , Nyf+GhostGridY, 2
        dy_S = yf(1+GhostGridX,jfine)   - yf(1+GhostGridX,jfine-1) ! FIXME: x-index
        dy_N = yf(1+GhostGridX,jfine+1) - yf(1+GhostGridX,jfine) ! FIXME: x-index
        dyc  = one/(dy_S + dy_N)
		DO kfine = 1+GhostGridZ , Nzf+GhostGridZ-1 ! FREE SURFACE LAYER NOT INCLUDED SINCE THERE WE USE DIRECT INJECTION
			DO ifine = 1+GhostGridX , Nxf+GhostGridX, 1+xcoarsen
				tmp3D(kfine,ifine,jfine) = (half*dyc)*(dy_S*tmp3D(kfine,ifine,jfine-1) + (dy_N+dy_S)*tmp3D(kfine,ifine,jfine) + &
				   dy_N*tmp3D(kfine,ifine,jfine+1))
			END DO
		END DO
	END DO
    ELSE
       WRITE (*,'(A)') 'Error: currently multigrid has not been implemented for grid without a single ghost layer.'
       STOP ! FORCED STOP
    ENDIF
ENDIF

! *******************************************
!			 Z-COARSEN
! *******************************************

IF (zcoarsen==1) THEN
!  print*,'Z-coarsen'
    IF (GhostGridZ==1) THEN
        ! We have Ghost Layers present
        ! OMIT Ghost Point Layer's from restriction

	! interior points, full stencil
	DO kfine = 1+GhostGridZ , Nzf+GhostGridZ-1, 2 ! omit free surface since there we use direct injection
        dz_U = zf(kfine+1) - zf(kfine)
        dz_D = zf(kfine)   - zf(kfine-1)
        dzc  = one/(dz_D + dz_U)
	    DO ifine = 1+GhostGridX , Nxf+GhostGridX, 1 + xcoarsen
			DO jfine = 1+GhostGridY , Nyf+GhostGridY, 1 + ycoarsen
				tmp3D(kfine,ifine,jfine) = (half*dzc)*(dz_D*tmp3D(kfine-1,ifine,jfine) + dz_U*tmp3D(kfine+1,ifine,jfine)) + &
				   half*tmp3D(kfine,ifine,jfine)
			END DO
		END DO
	END DO
    ELSE
       WRITE (*,'(A)') 'Error: currently multigrid has not been implemented for grid without a single ghost layer.'
       STOP ! FORCED STOP
    ENDIF

ENDIF

! DIRECT INJECTION
PHIcoarse(1+GhostGridZ:Nzc+GhostGridZ,1+GhostGridX:Nxc+GhostGridX,1+GhostGridY:Nyc+GhostGridY) = &
	tmp3D(1+GhostGridZ:Nzf+GhostGridZ:1+zcoarsen,1+GhostGridX:Nxf+GhostGridX:1+xcoarsen,1+GhostGridY:Nyf+GhostGridY:1+ycoarsen)

if (0==1) then ! if active we assume that the defect is a result of imposing boundary conditions... does not seem to make sense?? it should be assumed zero at boundary equations??
! APPROXIMATE GHOST POINT VALUES ON COARSE GRID
! This is needed for grids containing ghost points. Wall boundary conditions assumed.
DO kc = 1+GhostGridZ, Nzc+GhostGridZ
    DO jc = 1+GhostGridY, Nyc+GhostGridY
       ic = 1 ! WEST
       PHIcoarse(kc,ic,jc) = PHIcoarse(kc,ic+2,jc)
       ic = Nxc+GhostGridX*2 ! EAST
       PHIcoarse(kc,ic,jc) = PHIcoarse(kc,ic-2,jc)
  END DO
END DO

DO kc = 1+GhostGridZ, Nzc+GhostGridZ
  DO ic = 1+GhostGridX, Nxc+GhostGridX
       jc = 1 ! SOUTH
       PHIcoarse(kc,ic,jc) = PHIcoarse(kc,ic,jc+2)
       jc = Nxc+GhostGridY*2 ! NORTH
       PHIcoarse(kc,ic,jc) = PHIcoarse(kc,ic,jc-2)
  END DO
END DO

kc = 1
DO ic = 1+GhostGridX, Nxc+GhostGridX
  DO jc = 1+GhostGridY, Nyc+GhostGridY
     PHIcoarse(kc,ic,jc) = PHIcoarse(kc+2,ic,jc)
  END DO
END DO
end if
END SUBROUTINE MGRestriction3DExplicit


! =====================================================
subroutine rpt2(ixy,imp,maxm,meqn,mwaves,maux,mbc,mx,ql,qr,aux1,aux2,aux3,asdq,bmasdq,bpasdq)
! =====================================================
      implicit double precision (a-h,o-z)
!
!     # Riemann solver in the transverse direction for the elastic equations
!     # with varying material properties
!
!
!     # Contents of ql and qr:
!     #
!     # q(1,:) = sigma^{11} if ixy=1   or   sigma^{22} if ixy=2
!     # q(2,:) = sigma^{22} if ixy=1   or   sigma^{11} if ixy=2
!     # q(3,:) = sigma^{12} = sigma^{21}
!     # q(4,:) = u          if ixy=1   or   v          if ixy=2
!     # q(5,:) = v          if ixy=1   or   u          if ixy=2
!     #
!     # auxN holds corresponding slices of the aux array:
!     #  N = 1 for row below
!     #      2 for this row
!     #      3 for row above
!     #
!     #  auxN(1,i) = rho
!     #  auxN(2,i) = lambda
!     #  auxN(3,i) = mu
!     #  auxN(4,i) = cp
!     #  auxN(5,i) = cs
!
!
!
!     # Split asdq into down-going flux bmasdq and up-going flux bpasdq.
!
!     # imp=1  means  asdq=amdq,    imp=2 means asdq=apdq
!
      dimension     ql(meqn, 1-mbc:maxm+mbc)
      dimension     qr(meqn, 1-mbc:maxm+mbc)
      dimension   asdq(meqn, 1-mbc:maxm+mbc)
      dimension bmasdq(meqn, 1-mbc:maxm+mbc)
      dimension bpasdq(meqn, 1-mbc:maxm+mbc)
      dimension   aux1(maux, 1-mbc:maxm+mbc)
      dimension   aux2(maux, 1-mbc:maxm+mbc)
      dimension   aux3(maux, 1-mbc:maxm+mbc)
!
!
!
!     # set ku to point to  the component of the system that corresponds
!     # to velocity in the direction of this slice, kv to the orthogonal
!     # velocity.  Similarly ksig11 and ksig22 point to normal stresses.
!     # 3rd component is always shear stress sig12.
!
!
      if (ixy.eq.1) then
         ksig11 = 1
         ksig22 = 2
         ku = 4
         kv = 5
      else
         ksig11 = 2
         ksig22 = 1
         ku = 5
         kv = 4
      endif
!
!
      do i = 2-mbc, mx+mbc
!
!        # imp is used to flag whether wave is going to left or right,
!        # since material properties are different on the two sides
!
         if (imp.eq.1) then
!            # asdq = amdq, moving to left
             i1 = i-1
         else
!            # asdq = apdq, moving to right
             i1 = i
         endif
!
!        # The flux difference asdq is split into downward moving parts
!        # traveling at speeds -cp and -cs relative to the medium below and
!        # upward moving parts traveling
!        # at speeds +cp and +cs relative to the medium above.
!
!        # Note that the sum of these parts does not give all of asdq
!        # since there is also reflection at the interfaces which decreases
!        # the flux.
!
!        # jumps in asdq:
         dsig11 = asdq(ksig11,i)
         dsig22 = asdq(ksig22,i)
         dsig12 = asdq(3,i)
         du     = asdq(ku,i)
         dv     = asdq(kv,i)
!
!
!        # Material parameters in each row of cells:
         alamm = aux1(2,i1)
         alam  = aux2(2,i1)
         alamp = aux3(2,i1)
         amum  = aux1(3,i1)
         amu   = aux2(3,i1)
         amup  = aux3(3,i1)
         bulkm = alamm + 2.d0*amum
         bulk  = alam  + 2.d0*amu
         bulkp = alamp + 2.d0*amup

!        # P-wave and S-wave speeds in each row of cells:
         cpm = aux1(4,i1)
         cp  = aux2(4,i1)
         cpp = aux3(4,i1)
         csm = aux1(5,i1)
         cs  = aux2(5,i1)
         csp = aux3(5,i1)
!

!        # transmitted part of down-going P-wave:
         det = bulkm*cp + bulk*cpm
         if (det .eq. 0.d0) then
            write(6,*) 'det1 = 0 in rpt2'
            stop
            endif
         a1 = (cp*dsig22 + bulk*dv) / det

!        # transmitted part of up-going P-wave:
         det = bulk*cpp + bulkp*cp
         if (det .eq. 0.d0) then
            write(6,*) 'det2 = 0 in rpt2'
            stop
            endif
         a2 = (cp*dsig22 - bulk*dv) / det
!
!        # transmitted part of down-going S-wave:
         det = -(amum*cs + amu*csm)
         if (det .eq. 0.d0) then
             a3 = 0.d0
         else
             a3 = (cs*dsig12 + amu*du) / det
         endif

!        # transmitted part of up-going S-wave:
         det = -(amu*csp + amup*cs)
         if (det .eq. 0.d0) then
             a4 = 0.d0
         else
             a4 = (cs*dsig12 - amu*du) / det
         endif
!
!        # The down-going flux difference bmasdq is the product  -c * wave
!        # summed over down-going P-wave and S-wave:
!
         bmasdq(ksig11,i) = -cpm*a1*alamm
         bmasdq(ksig22,i) = -cpm*a1*bulkm
         bmasdq(3,i) =      -csm*a3*(-amum)
         bmasdq(ku,i) =     -csm*a3*(-csm)
         bmasdq(kv,i) =     -cpm*a1*(cpm)
!
!        # The up-going flux difference bpasdq is the product  c * wave
!        # summed over up-going P-wave and S-wave:
!
         bpasdq(ksig11,i) =  cpp*a2*alamp
         bpasdq(ksig22,i) =  cpp*a2*bulkp
         bpasdq(3,i) =       csp*a4*(-amup)
         bpasdq(ku,i) =      csp*a4*(csp)
         bpasdq(kv,i) =      cpp*a2*(-cpp)
!
      enddo
!
      return
      end


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------
MODULE m_genMTBasis

CONTAINS

  SUBROUTINE genMTBasis(atoms,enpara,vTot,fmpi,iType,jspin,usdus,f,g,flo,l_dftspinpol,l_writeArg)
    USE m_types
    USE m_constants
    USE m_radfun
    USE m_radflo
    !$  use omp_lib

    IMPLICIT NONE

    TYPE(t_atoms),  INTENT(IN)    :: atoms
    TYPE(t_enpara), INTENT(IN)    :: enpara
    TYPE(t_potden), INTENT(IN)    :: vTot
    TYPE(t_mpi),    INTENT(IN)    :: fmpi
    TYPE(t_usdus),  INTENT(INOUT) :: usdus

    INTEGER,        INTENT(IN)    :: iType
    INTEGER,        INTENT(IN)    :: jspin

    LOGICAL,        INTENT(IN)    :: l_dftspinpol

    REAL,           INTENT(INOUT) :: f(atoms%jmtd,2,0:atoms%lmaxd)
    REAL,           INTENT(INOUT) :: g(atoms%jmtd,2,0:atoms%lmaxd)
    REAL,           INTENT(INOUT) :: flo(atoms%jmtd,2,atoms%nlod)
    LOGICAL, OPTIONAL, INTENT(IN) :: l_writeArg

    INTEGER                       :: l,nodeu,noded
    REAL                          :: wronk

    LOGICAL    :: l_write,l_hia
    REAL       :: vrTmp(atoms%jmtd)
    INTEGER    :: i

    IF(PRESENT(l_writeArg)) THEN
      l_write = l_writeArg
    ELSE
      l_write = .TRUE.
    ENDIF

    l_write=l_write .and. fmpi%irank==0
    !$ l_write = l_write .and. omp_get_num_threads()==1

    IF (l_write) WRITE (oUnit,FMT=8000) iType

    DO l = 0,atoms%lmax(iType)
       !Check if the orbital is to be treated with Hubbard 1
       l_hia=.FALSE.
       DO i = atoms%n_u+1, atoms%n_u+atoms%n_hia
          IF(atoms%lda_u(i)%atomType.EQ.itype.AND.atoms%lda_u(i)%l.EQ.l) THEN
             l_hia=.TRUE.
          ENDIF
       ENDDO

       !In the case of a spin-polarized calculation with Hubbard 1 we want to treat
       !the correlated orbitals with a non-spin-polarized basis
       IF(l_hia.AND.SIZE(vTot%mt,4).GT.1.AND..NOT.l_dftspinpol) THEN
          vrTmp = (vTot%mt(:,0,iType,1) + vTot%mt(:,0,iType,2))/2.0
       ELSE
          vrTmp = vTot%mt(:,0,iType,jspin)
       ENDIF
       CALL radfun(l,iType,jspin,enpara%el0(l,iType,jspin),vrTmp,atoms,&
            f(1,1,l),g(1,1,l),usdus,nodeu,noded,wronk)
       IF (l_write) THEN
          WRITE (oUnit,FMT=8010) l,enpara%el0(l,iType,jspin),usdus%us(l,iType,jspin),usdus%dus(l,iType,jspin),&
               nodeu,usdus%uds(l,iType,jspin),usdus%duds(l,iType,jspin),noded,usdus%ddn(l,iType,jspin),wronk
       END IF
    END DO

    ! Generate the extra wavefunctions for the local orbitals, if there are any.
    IF (atoms%nlo(iType).GE.1) THEN
       CALL radflo(atoms,iType,jspin,enpara%ello0(1,1,jspin),vTot%mt(:,0,iType,jspin),f,g,fmpi,&
            usdus,usdus%uuilon(1,1,jspin),usdus%duilon(1,1,jspin),usdus%ulouilopn(1,1,1,jspin),flo)
    END IF

8000 FORMAT (1x,/,/,' wavefunction parameters for atom type',i3,':',&
         /,t32,'radial function',t79,'energy derivative',/,t3,&
         'l',t8,'energy',t26,'value',t39,'derivative',t53,&
         'nodes',t68,'value',t81,'derivative',t95,'nodes',t107,&
         'norm',t119,'wronskian')
8010 FORMAT (i3,f10.5,2 (5x,1p,2e16.7,i5),1p,2e16.7)

  END SUBROUTINE genMTBasis

END MODULE m_genMTBasis


      subroutine runY_00li1i2i3i4(k,l,i1,i2,i3,i4,Xtwiddle,Gtwiddle,
     . Shat7,N0)
      implicit none
C---  Expression for extension of Eq. 5.60c
C---  Calculates D00li1i2i3i4, requires D00lli1i2i3
C---  Small terms of order Xtwiddle(0,k)*Diiiiii,Xtwiddle(0,0)*Diiiiiii
C---  Denominator Gtwiddle(k,l)
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,k,l,i1,i2,i3,i4,np
      parameter(np=3)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat7(np,z6max,-2:0)

      if (  (i1.eq.l) .or. (i2.eq.l) .or. (i3.eq.l) .or. (i4.eq.l)
     . .or. (i1.eq.0) .or. (i2.eq.0) .or. (i3.eq.0) .or. (i4.eq.0)) then
      return
      endif

      do ep=-2,0
      Dv(dzziiiii(z5(l,i1,i2,i3,i4))+N0,ep)=
     .(-2d0*Gtwiddle(k,i1)*Dv(dzziiiii(z5(l,l,i2,i3,i4))+N0,ep)
     . -2d0*Gtwiddle(k,i2)*Dv(dzziiiii(z5(l,l,i1,i3,i4))+N0,ep)
     . -2d0*Gtwiddle(k,i3)*Dv(dzziiiii(z5(l,l,i1,i2,i4))+N0,ep)
     . -2d0*Gtwiddle(k,i4)*Dv(dzziiiii(z5(l,l,i1,i2,i3))+N0,ep)
     . +Gtwiddle(k,1)*Shat7(1,z6(l,l,i1,i2,i3,i4),ep)
     . +Gtwiddle(k,2)*Shat7(2,z6(l,l,i1,i2,i3,i4),ep)
     . +Gtwiddle(k,3)*Shat7(3,z6(l,l,i1,i2,i3,i4),ep)
     . +Xtwiddle(k,0)*Dv(diiiiii(z6(l,l,i1,i2,i3,i4))+N0,ep)
     . -Xtwiddle(0,0)*Dv(diiiiiii(z7(k,l,l,i1,i2,i3,i4))+N0,ep))
     . /(4d0*Gtwiddle(k,l))

      enddo

      return
      end


! (C) Copyright 2018-2019 UCAR
!
! This software is licensed under the terms of the Apache Licence Version 2.0
! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.

module pressure_vt_mod

use fv3jedi_constants_mod, only: kappa
use fv3jedi_geom_mod, only: fv3jedi_geom
use fv3jedi_kinds_mod, only: kind_real

implicit none
private

public delp_to_pe_p_logp
public pe_to_pkz
public ps_to_pkz
public pe_to_delp
public delp_to_pe
public pe_to_pk
public ps_to_delp
public ps_to_pe
public ps_to_delp_tl
public ps_to_delp_ad

contains

!----------------------------------------------------------------------------
! Pressure thickness to pressure (edge), pressure (mid) and log p (mid) -----
!----------------------------------------------------------------------------

subroutine delp_to_pe_p_logp(geom,delp,pe,p,logp)

 implicit none
 type(fv3jedi_geom)  , intent(in ) :: geom !Geometry for the model
 real(kind=kind_real), intent(in ) :: delp(geom%isc:geom%iec,geom%jsc:geom%jec,1:geom%npz)   !Pressure thickness
 real(kind=kind_real), intent(out) ::   pe(geom%isc:geom%iec,geom%jsc:geom%jec,1:geom%npz+1) !Pressure edge/interface
 real(kind=kind_real), intent(out) ::    p(geom%isc:geom%iec,geom%jsc:geom%jec,1:geom%npz)   !Pressure mid point
 real(kind=kind_real), optional, intent(out) :: logp(geom%isc:geom%iec,geom%jsc:geom%jec,1:geom%npz)   !Log of pressure mid point

 !Locals
 integer :: isc,iec,jsc,jec,k

 isc = geom%isc
 iec = geom%iec
 jsc = geom%jsc
 jec = geom%jec

 !Pressure at layer edge
 pe(isc:iec,jsc:jec,1) = geom%ptop
 do k = 2,geom%npz+1
   pe(isc:iec,jsc:jec,k) = pe(isc:iec,jsc:jec,k-1) + delp(isc:iec,jsc:jec,k-1)
 enddo

 !Midpoint pressure
 p(isc:iec,jsc:jec,:) = 0.5*(pe(isc:iec,jsc:jec,2:geom%npz+1) + pe(isc:iec,jsc:jec,1:geom%npz))

 if (present(logp)) then
   !Log pressure
   logp(isc:iec,jsc:jec,:) = log(p(isc:iec,jsc:jec,:))
 endif

end subroutine delp_to_pe_p_logp

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

subroutine pe_to_pkz(geom,pe,pkz)

implicit none
type(fv3jedi_geom)  , intent(in ) :: geom !Geometry for the model
real(kind=kind_real), intent(in ) ::  pe(geom%isc:geom%iec,geom%jsc:geom%jec,1:geom%npz+1) !Pressure edge/interface
real(kind=kind_real), intent(out) :: pkz(geom%isc:geom%iec,geom%jsc:geom%jec,1:geom%npz)   !Pressure to the kappa

integer :: k
real(kind=kind_real) :: peln(geom%isc:geom%iec,geom%jsc:geom%jec,1:geom%npz+1)
real(kind=kind_real) ::   pk(geom%isc:geom%iec,geom%jsc:geom%jec,1:geom%npz+1)

peln = log(pe)
pk = exp(kappa*peln)

do k=1,geom%npz
  pkz(:,:,k) = (pk(:,:,k+1)-pk(:,:,k)) / (kappa*(peln(:,:,k+1)-peln(:,:,k)))
enddo

end subroutine pe_to_pkz

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

subroutine pe_to_delp(geom,pe,delp)

 implicit none
 type(fv3jedi_geom)  , intent(in ) :: geom !Geometry for the model
 real(kind=kind_real), intent(in ) ::   pe(geom%isc:geom%iec,geom%jsc:geom%jec,1:geom%npz+1) !Pressure edge/interface
 real(kind=kind_real), intent(out) :: delp(geom%isc:geom%iec,geom%jsc:geom%jec,1:geom%npz)   !Pressure thickness

 !Locals
 integer :: isc,iec,jsc,jec,k

 isc = geom%isc
 iec = geom%iec
 jsc = geom%jsc
 jec = geom%jec

 !Pressure at layer edge
 do k = 1,geom%npz
   delp(isc:iec,jsc:jec,k) = pe(isc:iec,jsc:jec,k+1) - pe(isc:iec,jsc:jec,k)
 enddo

end subroutine pe_to_delp

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

subroutine delp_to_pe( geom, delp, pe )

implicit none
type(fv3jedi_geom)  , intent(in ) :: geom !Geometry for the model
real(kind=kind_real), intent(in ) :: delp(geom%isc:geom%iec,geom%jsc:geom%jec,1:geom%npz)   !Pressure thickness
real(kind=kind_real), intent(out) ::   pe(geom%isc:geom%iec,geom%jsc:geom%jec,1:geom%npz+1) !Pressure edge/interface

!Locals
integer :: isc,iec,jsc,jec,k

isc = geom%isc
iec = geom%iec
jsc = geom%jsc
jec = geom%jec

!Pressure at layer edge
pe(isc:iec,jsc:jec,1) = geom%ptop
do k = 2,geom%npz+1
  pe(isc:iec,jsc:jec,k) = pe(isc:iec,jsc:jec,k-1) + delp(isc:iec,jsc:jec,k-1)
enddo

end subroutine delp_to_pe

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

subroutine pe_to_pk( geom, pe, pk )

implicit none
type(fv3jedi_geom)  , intent(in ) :: geom !Geometry for the model
real(kind=kind_real), intent(in ) :: pe(geom%isc:geom%iec,geom%jsc:geom%jec,1:geom%npz+1) !Pressure edge/interface
real(kind=kind_real), intent(out) :: pk(geom%isc:geom%iec,geom%jsc:geom%jec,1:geom%npz)   !Pressure to the kappa

!Locals
integer :: i, j, k
real(kind=kind_real) :: pel1, pel2
real(kind=kind_real) :: pek1, pek2

do k=1,geom%npz
  do j = geom%jsc,geom%jec
    do i = geom%isc,geom%iec

      pel1 = log(pe(i,j,k+1))
      pel2 = log(pe(i,j,k))

      pek1 = exp(kappa*pel1)
      pek2 = exp(kappa*pel2)

      pk(i,j,k) = (pek1-pek2)/(kappa*(pel1-pel2))

    end do
  end do
end do

end subroutine pe_to_pk

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

subroutine ps_to_pe(geom,ps,pe)

 implicit none
 type(fv3jedi_geom)  , intent(in   ) :: geom !Geometry for the model
 real(kind=kind_real), intent(in   ) :: ps(geom%isc:geom%iec,geom%jsc:geom%jec,1           )   !Surface pressure
 real(kind=kind_real), intent(inout) :: pe(geom%isc:geom%iec,geom%jsc:geom%jec,1:geom%npz+1)   !Pressure thickness

 integer :: k

 do k = 1,geom%npz+1
   pe(:,:,k) = geom%ak(k) + geom%bk(k) * ps(:,:,1)
 enddo

endsubroutine ps_to_pe

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

subroutine ps_to_pkz(geom,ps,pkz)

 implicit none
 type(fv3jedi_geom)  , intent(in   ) :: geom !Geometry for the model
 real(kind=kind_real), intent(in   ) ::  ps(geom%isc:geom%iec,geom%jsc:geom%jec,1         )   !Surface pressure
 real(kind=kind_real), intent(inout) :: pkz(geom%isc:geom%iec,geom%jsc:geom%jec,1:geom%npz)   !Pressure ^ kappa

 integer :: k
 real(kind=kind_real) :: pe(geom%isc:geom%iec,geom%jsc:geom%jec,1:geom%npz+1) !Pressure

 call ps_to_pe(geom, ps, pe)
 call pe_to_pkz(geom, pe, pkz)

endsubroutine ps_to_pkz

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

subroutine ps_to_delp(geom,ps,delp)

 implicit none
 type(fv3jedi_geom)  , intent(in   ) :: geom !Geometry for the model
 real(kind=kind_real), intent(in   ) ::   ps(geom%isc:geom%iec,geom%jsc:geom%jec           )   !Surface pressure
 real(kind=kind_real), intent(inout) :: delp(geom%isc:geom%iec,geom%jsc:geom%jec,1:geom%npz)   !Pressure thickness

 integer :: isc,iec,jsc,jec,i,j,k

 isc = geom%isc
 iec = geom%iec
 jsc = geom%jsc
 jec = geom%jec

 do k = 1,geom%npz
   do j = jsc,jec
     do i = isc,iec
       delp(i,j,k) = geom%ak(k+1) + geom%bk(k+1)*ps(i,j) - (geom%ak(k) + geom%bk(k)*ps(i,j))
     enddo
   enddo
 enddo

endsubroutine ps_to_delp

subroutine ps_to_delp_tl(geom,ps_tl,delp_tl)

 implicit none
 type(fv3jedi_geom)  , intent(in   ) :: geom !Geometry for the model
 real(kind=kind_real), intent(in   ) ::   ps_tl(geom%isc:geom%iec,geom%jsc:geom%jec           )   !Surface pressure
 real(kind=kind_real), intent(inout) :: delp_tl(geom%isc:geom%iec,geom%jsc:geom%jec,1:geom%npz)   !Pressure thickness

 integer :: isc,iec,jsc,jec,i,j,k

 isc = geom%isc
 iec = geom%iec
 jsc = geom%jsc
 jec = geom%jec

 delp_tl = 0.0_kind_real
 do k = 1,geom%npz
   do j = jsc,jec
     do i = isc,iec
       delp_tl(i,j,k) = geom%bk(k+1)*ps_tl(i,j) - geom%bk(k)*ps_tl(i,j)
     enddo
   enddo
 enddo

endsubroutine ps_to_delp_tl

subroutine ps_to_delp_ad(geom,ps_ad,delp_ad)

 implicit none
 type(fv3jedi_geom)  , intent(in   ) :: geom !Geometry for the model
 real(kind=kind_real), intent(inout) ::   ps_ad(geom%isc:geom%iec,geom%jsc:geom%jec           )   !Surface pressure
 real(kind=kind_real), intent(inout) :: delp_ad(geom%isc:geom%iec,geom%jsc:geom%jec,1:geom%npz)   !Pressure thickness

 integer :: isc,iec,jsc,jec,i,j,k

 isc = geom%isc
 iec = geom%iec
 jsc = geom%jsc
 jec = geom%jec

 ps_ad = 0.0_kind_real

 do k = geom%npz,1,-1
   do j = jec,jsc,-1
     do i = iec,isc,-1
       ps_ad(i,j) = ps_ad(i,j) + (geom%bk(k+1) - geom%bk(k))*delp_ad(i,j,k)
     enddo
   enddo
 enddo

endsubroutine ps_to_delp_ad

end module pressure_vt_mod


! { dg-do compile }
! { dg-options "-O3 -fwhole-file" }
      CALL UVSET(NX,NY,NZ,HVAR,ZET,NP,DZ,DKM,UM,VM,UG,VG,TM,DCDX, ! { dg-warning "Rank mismatch" }
     *ITY,ISH,NSMT,F)
         CALL DCTDX(NX,NY,NX1,NFILT,C(MLAG),DCDX(MLAG),HELP,HELPA,
     *   HELP,HELPA,FY,FYC,SAVEY)
      END
      SUBROUTINE PADEC(DKS,DKDS,HVAR,WM,WG,FN,NS,AN,BN,CN,IT)
      COMPLEX*16 WM(*),WG(*),FN(*),AN(*),BN(*),CN(*)
         BN(J)=F4+AS+GAMMA*F2
         CN(J)=F4-AS+GAMMA*F2
         FN(J)=(AS+F4-GAMMA*F2)*H2+(F4-AS-GAMMA*F2)*H0+
     *   H1*(F3-GAMMA/3.D0)+GAMMA*WG(J)-CONST
      END
      SUBROUTINE UVSET(NX,NY,NZ,HVAR,ZET,NP,DZ,DKM,UM,VM,UG,VG,TM,
     *WORK,ITY,IH,NSMT,F)
      DIMENSION HVAR(*),ZET(*),TM(*),DKM(*),UM(*),VM(*),UG(*),VG(*),
     *WORK(*)
      IF(IH.EQ.0) THEN
         CALL PADEC(DKM,VM,HVAR,WORK(LWM),WORK(LWG), ! { dg-warning "Rank mismatch" }
     *   WORK(LF),NZ,WORK(LA),WORK(LB),WORK(LC),ITY)
      ENDIF
      END


      REAL FUNCTION SATAN2 (Y, X)

C  Safe version of arctan-2 function; returns zero when both x and y
C  are zero.

      REAL  X,Y

      IF (X .EQ. 0.0 .AND. Y .EQ. 0.0) THEN
         SATAN2 = 0.0
      ELSE
         SATAN2 = ATAN2(Y,X)
      ENDIF

      END


program t
  integer :: i, j

  do i = 1, 10
    do j = 1, 10
      if (i + j < 10 ) exit
      print *, i, j
    end do
  end do

end program t