      SUBROUTINE cumnor(arg,result,ccum)
C**********************************************************************
C
C     SUBROUINE CUMNOR(X,RESULT,CCUM)
C
C
C                              Function
C
C
C     Computes the cumulative  of    the  normal   distribution,   i.e.,
C     the integral from -infinity to x of
C          (1/sqrt(2*pi)) exp(-u*u/2) du
C
C     X --> Upper limit of integration.
C                                        X is DOUBLE PRECISION
C
C     RESULT <-- Cumulative normal distribution.
C                                        RESULT is DOUBLE PRECISION
C
C     CCUM <-- Compliment of Cumulative normal distribution.
C                                        CCUM is DOUBLE PRECISION
C
C
C     Renaming of function ANORM from:
C
C     Cody, W.D. (1993). "ALGORITHM 715: SPECFUN - A Portabel FORTRAN
C     Package of Special Function Routines and Test Drivers"
C     acm Transactions on Mathematical Software. 19, 22-32.
C
C     with slight modifications to return ccum and to deal with
C     machine constants.
C
C**********************************************************************
C
C
C Original Comments:
C------------------------------------------------------------------
C
C This function evaluates the normal distribution function:
C
C                              / x
C                     1       |       -t*t/2
C          P(x) = ----------- |      e       dt
C                 sqrt(2 pi)  |
C                             /-oo
C
C   The main computation evaluates near-minimax approximations
C   derived from those in "Rational Chebyshev approximations for
C   the error function" by W. J. Cody, Math. Comp., 1969, 631-637.
C   This transportable program uses rational functions that
C   theoretically approximate the normal distribution function to
C   at least 18 significant decimal digits.  The accuracy achieved
C   depends on the arithmetic system, the compiler, the intrinsic
C   functions, and proper selection of the machine-dependent
C   constants.
C
C*******************************************************************
C*******************************************************************
C
C Explanation of machine-dependent constants.
C
C   MIN   = smallest machine representable number.
C
C   EPS   = argument below which anorm(x) may be represented by
C           0.5  and above which  x*x  will not underflow.
C           A conservative value is the largest machine number X
C           such that   1.0 + X = 1.0   to machine precision.
C*******************************************************************
C*******************************************************************
C
C Error returns
C
C  The program returns  ANORM = 0     for  ARG .LE. XLOW.
C
C
C Intrinsic functions required are:
C
C     ABS, AINT, EXP
C
C
C  Author: W. J. Cody
C          Mathematics and Computer Science Division
C          Argonne National Laboratory
C          Argonne, IL 60439
C
C  Latest modification: March 15, 1992
C
C------------------------------------------------------------------
      INTEGER i
      DOUBLE PRECISION a,arg,b,c,d,del,eps,half,p,one,q,result,sixten,
     +                 temp,sqrpi,thrsh,root32,x,xden,xnum,y,xsq,zero,
     +                 min,ccum
      DIMENSION a(5),b(4),c(9),d(8),p(6),q(5)
C------------------------------------------------------------------
C  External Function
C------------------------------------------------------------------
      DOUBLE PRECISION spmpar
      EXTERNAL spmpar
C------------------------------------------------------------------
C  Mathematical constants
C
C  SQRPI = 1 / sqrt(2*pi), ROOT32 = sqrt(32), and
C  THRSH is the argument for which anorm = 0.75.
C------------------------------------------------------------------
      DATA one,half,zero,sixten/1.0D0,0.5D0,0.0D0,1.60D0/,
     +     sqrpi/3.9894228040143267794D-1/,thrsh/0.66291D0/,
     +     root32/5.656854248D0/
C------------------------------------------------------------------
C  Coefficients for approximation in first interval
C------------------------------------------------------------------
      DATA a/2.2352520354606839287D00,1.6102823106855587881D02,
     +     1.0676894854603709582D03,1.8154981253343561249D04,
     +     6.5682337918207449113D-2/
      DATA b/4.7202581904688241870D01,9.7609855173777669322D02,
     +     1.0260932208618978205D04,4.5507789335026729956D04/
C------------------------------------------------------------------
C  Coefficients for approximation in second interval
C------------------------------------------------------------------
      DATA c/3.9894151208813466764D-1,8.8831497943883759412D00,
     +     9.3506656132177855979D01,5.9727027639480026226D02,
     +     2.4945375852903726711D03,6.8481904505362823326D03,
     +     1.1602651437647350124D04,9.8427148383839780218D03,
     +     1.0765576773720192317D-8/
      DATA d/2.2266688044328115691D01,2.3538790178262499861D02,
     +     1.5193775994075548050D03,6.4855582982667607550D03,
     +     1.8615571640885098091D04,3.4900952721145977266D04,
     +     3.8912003286093271411D04,1.9685429676859990727D04/
C------------------------------------------------------------------
C  Coefficients for approximation in third interval
C------------------------------------------------------------------
      DATA p/2.1589853405795699D-1,1.274011611602473639D-1,
     +     2.2235277870649807D-2,1.421619193227893466D-3,
     +     2.9112874951168792D-5,2.307344176494017303D-2/
      DATA q/1.28426009614491121D00,4.68238212480865118D-1,
     +     6.59881378689285515D-2,3.78239633202758244D-3,
     +     7.29751555083966205D-5/
C------------------------------------------------------------------
C  Machine dependent constants
C------------------------------------------------------------------
      eps = spmpar(1)*0.5D0
      min = spmpar(2)
C------------------------------------------------------------------
      x = arg
      y = abs(x)
      IF (y.LE.thrsh) THEN
C------------------------------------------------------------------
C  Evaluate  anorm  for  |X| <= 0.66291
C------------------------------------------------------------------
          xsq = zero
          IF (y.GT.eps) xsq = x*x
          xnum = a(5)*xsq
          xden = xsq
          DO 10 i = 1,3
              xnum = (xnum+a(i))*xsq
              xden = (xden+b(i))*xsq
   10     CONTINUE
          result = x* (xnum+a(4))/ (xden+b(4))
          temp = result
          result = half + temp
          ccum = half - temp
C------------------------------------------------------------------
C  Evaluate  anorm  for 0.66291 <= |X| <= sqrt(32)
C------------------------------------------------------------------
      ELSE IF (y.LE.root32) THEN
          xnum = c(9)*y
          xden = y
          DO 20 i = 1,7
              xnum = (xnum+c(i))*y
              xden = (xden+d(i))*y
   20     CONTINUE
          result = (xnum+c(8))/ (xden+d(8))
          xsq = aint(y*sixten)/sixten
          del = (y-xsq)* (y+xsq)
          result = exp(-xsq*xsq*half)*exp(-del*half)*result
          ccum = one - result
          IF (x.GT.zero) THEN
              temp = result
              result = ccum
              ccum = temp
          END IF
C------------------------------------------------------------------
C  Evaluate  anorm  for |X| > sqrt(32)
C------------------------------------------------------------------
      ELSE
          result = zero
          xsq = one/ (x*x)
          xnum = p(6)*xsq
          xden = xsq
          DO 30 i = 1,4
              xnum = (xnum+p(i))*xsq
              xden = (xden+q(i))*xsq
   30     CONTINUE
          result = xsq* (xnum+p(5))/ (xden+q(5))
          result = (sqrpi-result)/y
          xsq = aint(x*sixten)/sixten
          del = (x-xsq)* (x+xsq)
          result = exp(-xsq*xsq*half)*exp(-del*half)*result
          ccum = one - result
          IF (x.GT.zero) THEN
              temp = result
              result = ccum
              ccum = temp
          END IF

      END IF

      IF (result.LT.min) result = 0.0D0
      IF (ccum.LT.min) ccum = 0.0D0
C------------------------------------------------------------------
C  Fix up for negative argument, erf, etc.
C------------------------------------------------------------------
C----------Last card of ANORM ----------
      END


!>
!> @file
!>
!>  PLASMA is a software package provided by:
!>  University of Tennessee, US,
!>  University of Manchester, UK.
!>
!> @precisions normal z -> s d c
!>
program test_zgetrs
    use, intrinsic :: iso_fortran_env

    use plasma
    implicit none

    integer, parameter :: sp = REAL32
    integer, parameter :: dp = REAL64

    ! set working precision, this value is rewritten for different precisions
    integer, parameter :: wp = dp

    ! matrix
    complex(wp), allocatable :: A(:,:)
    complex(wp), allocatable :: Aref(:,:)

    ! right-hand side
    complex(wp), allocatable :: B(:,:)
    complex(wp), allocatable :: Bref(:,:)

    ! vector of row permutations
    integer, allocatable :: ipiv(:)

    ! dimensions
    integer :: n
    integer :: nrhs

    integer :: lda
    integer :: ldb

    integer :: nb
    integer :: ib

    integer :: num_panel_threads

    real(wp) :: tol

    ! auxiliary variables
    integer :: info

    integer :: seed(4) = [0, 0, 0, 1]

    real(wp) :: normA
    real(wp) :: normX
    real(wp) :: normR

    real(wp), allocatable :: work(:)
    real(wp) :: zlange, dlamch

    integer :: num_panel_threads_check

    ! Set parameters.
    n    = 2000 ! number of rows and columns
    nrhs = 1000 ! number of right-hand sides

    nb   = 256  ! tile size (square tiles)
    ib   = 64   ! inner blocking size within a tile
    num_panel_threads = 2  ! number of threads for panel factorization

    ! tolerance for the correctness check
    tol = 50.0 * dlamch('E')

    ! Initialize arrays.
    lda  = n    ! leading dimension of A
    allocate(A(lda, n), Aref(lda, n))
    call zlarnv(1, seed, lda*n, A)
    Aref = A

    ldb  =  n  ! leading dimension of right-hand side matrix B
    allocate(B(ldb, nrhs), Bref(ldb, nrhs))
    call zlarnv(1, seed, ldb*nrhs, B)
    Bref = B

    allocate(ipiv(n))

    write(*,'(a, i6, a, i6)') " Testing LU solution with a matrix ", n, " x ", n
    write(*,'(a, i6)')        "  tile size:        ", nb
    write(*,'(a, i6)')        "  inner block size: ", ib

    !==============================================
    ! Initialize PLASMA.
    !==============================================
    call plasma_init(info)
    call check_error('plasma_init()', info)

    !==============================================
    ! Set PLASMA parameters.
    !==============================================
    ! set tile size
    call plasma_set(PlasmaNb, nb, info)
    call check_error('plasma_set()', info)

    ! set inner blocking size
    call plasma_set(PlasmaIb, ib, info)
    call check_error('plasma_set()', info)

    ! set number of threads for panel factorization
    call plasma_set(PlasmaNumPanelThreads, num_panel_threads, info)
    call check_error('plasma_set()', info)

    call plasma_get(PlasmaNumPanelThreads, num_panel_threads_check, info)
    if (num_panel_threads_check /= num_panel_threads) then
        write(*,'(a, i2, a, i2)') &
            "Something is wrong - number of threads for panel factorization " &
            //"is not set correctly:", &
            num_panel_threads_check, " not the same as ", num_panel_threads
    end if

    !==============================================
    ! Call LU factorization for A.
    !==============================================
    call plasma_zgetrf(n, n, A, lda, ipiv, info)
    call check_error('plasma_zgetrf()', info)

    !==============================================
    ! Call LU back-substitution for B.
    !==============================================
    call plasma_zgetrs(n, nrhs, A, lda, ipiv, B, ldb, info)
    call check_error('plasma_zgetrs()', info)

    !==============================================
    ! Finalize PLASMA.
    !==============================================
    call plasma_finalize(info)
    call check_error('plasma_finalize()', info)

    allocate(work(n))
    normA = zlange('I', n, n, Aref, lda, work)

    normX = zlange('I', n, nrhs, B, ldb, work)

    ! compute residual B - A*X
    Bref = Bref - matmul(Aref, B)
    normR = zlange('I', n, nrhs, Bref, ldb, work)

    ! normalize the residual
    if (normA /= 0.0 .and. normX /= 0.0) then
       normR = normR / (n * normA * normX)
    end if

    ! print output of the check
    write(*,'(a, e13.6)') &
        "  Residual of solution, measured as |B - A*X|_oo: ", normR
    if (normR < tol) then
        write(*,'(a)') "  The result is CORRECT."
    else
        write(*,'(a)') "  The result is WRONG!"
    end if
    write(*,'(a)') ""

    deallocate(A)
    deallocate(Aref)
    deallocate(B)
    deallocate(Bref)
    deallocate(ipiv)
    deallocate(work)

contains

    subroutine check_error(routine_name, code)
        use plasma
        implicit none
        character(len=*) :: routine_name
        integer :: code

        if (code /= PlasmaSuccess) then
            write(*,'(a, i2, a, a)') "Error ", code, "in a call to ", &
                trim(routine_name)
        end if
    end subroutine

end program test_zgetrs


! README file:
! 		  SX-3/44 Supercomputer at Dorval
!
! 		       Sample Performance Run
!
!      The following fortran program is a "dusty deck" used by myself to
! make quick comparisons  of  the various computers offered for sale  to
! this  site. The program is known as a shallow water model, a type   of
! test  harness used by  meteorologists  to   experiment  with   various
! integration schemes. By changing  the resolution of  the model it   is
! possible to scale this code to a  wide range of computational engines.
! I  have  run  this  on everything from  an  IBM  PC  to  all  of   the
! supercomputers installed at this site.
!
!      The code is a  "dusty  deck" in  the sense that it  is  run using
! compiler options at   the   command  line  only. The code   is     not
! particularly   written for any   type  of  computer, however, in   the
! implementation below, would qualify for something in  the  long vector
! domain. The program consists of 3 modules, the main program "SHALLOW",
! and 2 subroutines "PLOT"  and "RANGE". The latter 2 routines are  used
! to get output for display on a graphics  device, in this  case, an IBM
! PC  with a  CGA  graphics  screen. The statistics  on  the run are  as
! follows...
!
!      Vectorization  Ratio in  SHALLOW 99.75% Average Vector Length  in
! SHALLOW 213 Computation rate    in   SHALLOW 1.436 GFLOPS Number    of
! processors 1
!
!      This is certainly not a  high profile benchmark code, but is  has
! shown up the differences amongst various computers for application  to
! meteorological applications at  this  site. I call   this  my 1 minute
! benchmark because it usually requires less than 1 minute to move it to
! a new machine, compile it and get it running.
!
!      If anyone runs this on other machines, I would  like  to get back
! the numbers.
!
!
! Iain B. Findleton
!
!
! port to HPF/HPFC (FC, 12/06/96):
! - the code is simple because no border conditions
! - should be flip-flopped... (but arg passing in trouble -> copy)
! - wrapped around... should do sg about corners...
!
! Log:
! - sizes moved as parameters m & n [MAIN,RANGE,PLOT]
! - explicit types
! - DO/ENDDO
! - loop distribution [60,70,75,100,110,115,200,210,215,320,325]
! - loop interchange [801,901]
! - loop structure changed [802-803(ijk->ij),901(ifs->min/max)]
! - INDEPENDENT, NEW & REDUCTION directives
! - (commented) HOST/END HOST directives for I/Os
! - static mapping directives [MAIN,RANGE,PLOT]
!
      PROGRAM SHALLOW

      integer m,n
      parameter(m=320,n=200)

C ***
C *** BENCHMARK WEATHER PREDICTION PROGRAM FOR COMPARING THE PERFORMANCE
C *** OF CURRENT SUPERCOMPUTERS. THE MODEL IS BASED ON THE PAPER, "THE
C *** DYNAMICS OF FINITE-DIFFERENCE MODELS OF THE SHALLOW-WATER
C *** EQUATIONS," BY R. SADOURNY, J. ATM. SCI., VOL.32, NO.4, APRIL 1975
C *** CODE BY PAUL N. SWARZTRAUBER, NATIONAL CENTER FOR ATMOSPHERIC
C *** RESEARCH, BOULDER, COLORADO   OCTOBER 1984.
C ***

      REAL U(m,n),V(m,n),P(m,n),UNEW(m,n),PNEW(m,n),UOLD(m,n),
     $     VOLD(m,n),POLD(m,n),CU(m,n),CV(m,n),Z(m,n),H(m,n),PSI(m,n)
      REAL VNEW(m,n)
      CHARACTER*16 LABEL(5)

      real A,DT,TDT,TIME,DX,DY,ALPHA,PI,TPI,DI,DJ
      integer ITMAX,MPRINT,MM1,NM1,I,J

!hpf$ processors procs(2,2)
!hpf$ template domain(m,n)
!hpf$ align with domain:: U,V,P,UNEW,PNEW,UOLD,VOLD,POLD,
!hpf$x      CU,CV,Z,H,PSI,VNEW
!hpf$ distribute (block,block) onto procs:: domain

      OPEN(UNIT=2,FORM='UNFORMATTED')

      LABEL(1)='PRESSURE FIELD  '
      LABEL(2)='EAST/WEST WIND  '
      LABEL(3)='NORTH/SOUTH WIND'
      LABEL(4)='GEOPOTENTIAL    '
      LABEL(5)='HEIGHT FIELD    '

      A = 1.E6
      DT = 90.
      TDT = 90.
      TIME = 0.
      DX = 1.E5
      DY = 1.E5
      ALPHA = .001
      ITMAX = 2400
      MPRINT = 100
      MM1 = m-1
      NM1 = n-1
      PI = 4.*ATAN(1.)
      TPI = PI+PI
      DI = TPI/FLOAT(M)
      DJ = TPI/FLOAT(N)

C *** INITIAL VALUES OF THE STREAM FUNCTION [50]

!hpf$ independent(J,I)
      DO J=1,n
         DO I=1,m
            PSI(I,J) = A*SIN((FLOAT(I)-.5)*DI)*SIN((FLOAT(J)-.5)*DJ)
         ENDDO
      ENDDO

C *** INITIALIZE VELOCITIES [60]

!hpf$ independent(J,I)
      DO J=1,NM1
         DO I=2,m
            U(I,J) = -(PSI(I,J+1)-PSI(I,J))/DY
         ENDDO
      ENDDO
!hpf$ independent(J,I)
      DO J=2,n
         DO I=1,MM1
            V(I,J) = (PSI(I+1,J)-PSI(I,J))/DX
         ENDDO
      ENDDO

C *** PERIODIC CONTINUATION [70,75,86]

!hpf$ independent
      DO J=1,NM1
         U(1,J) = U(m,J)
      ENDDO
!hpf$ independent
      DO J=1,NM1
         V(m,J+1) = V(1,J+1)
      ENDDO

!hpf$ independent
      DO I=2,m
         U(I,n) = U(I,1)
      ENDDO
!hpf$ independent
      DO I=1,MM1
         V(I,1) = V(I,n)
      ENDDO

! corners...
      U(1,n) = U(m,1)
      V(m,1) = V(1,n)

!hpf$ independent(J,I)
      DO J=1,n
         DO I=1,m
            UOLD(I,J) = U(I,J)
            VOLD(I,J) = V(I,J)
            POLD(I,J) = 50000.
            P(I,J) = 50000.
         ENDDO
      ENDDO

C *** PRINT INITIAL VALUES

C!fcd$ host
C     WRITE(*,390) N,M,DX,DY,DT,ALPHA
C 390 FORMAT('1NUMBER OF POINTS IN THE X DIRECTION',I8/
C    1     ' NUMBER OF POINTS IN THE Y DIRECTION',I8/
C    2     ' GRID SPACING IN THE X DIRECTION    ',F8.0/
C    3     ' GRID SPACING IN THE Y DIRECTION    ',F8.0/
C    4     ' TIME STEP                          ',F8.0/
C    5     ' TIME FILTER PARAMETER              ',F8.3)
C     MNMIN = MIN0(M,N)
C     WRITE(*,391) (POLD(I,I),I=1,MNMIN)
C 391 FORMAT(/' INITIAL DIAGONAL ELEMENTS OF P ' //,(8E16.6))
C     WRITE(*,392) (UOLD(I,I),I=1,MNMIN)
C 392 FORMAT(/' INITIAL DIAGONAL ELEMENTS OF U ' //,(8E16.6))
C     WRITE(*,393) (VOLD(I,I),I=1,MNMIN)
C 393 FORMAT(/' INITIAL DIAGONAL ELEMENTS OF V ' //,(8E16.6))
C!fcd$ end host
      NCYCLE = 0

!
! INFINITE LOOP with a STOP
!
   90 NCYCLE = NCYCLE + 1

C *** COMPUTE CAPITAL U, CAPITAL V, Z, AND H [100]

      FSDX = 4./DX
      FSDY = 4./DY

!hpf$ independent(J,I)
      DO J=1,NM1
         DO I=2,m
            CU(I,J) = .5*(P(I,J)+P(I-1,J))*U(I,J)
         ENDDO
      ENDDO
!hpf$ independent(J,I)
      DO J=2,n
         DO I=1,MM1
            CV(I,J) = .5*(P(I,J)+P(I,J-1))*V(I,J)
         ENDDO
      ENDDO
!hpf$ independent(J,I)
      DO J=2,n
         DO I=2,m
            Z(I,J) = (FSDX*(V(I,J)-V(I-1,J))-FSDY*(U(I,J)
     1           -U(I,J-1)))/(P(I-1,J-1)+P(I,J-1)+P(I,J)+P(I-1,J))
         ENDDO
      ENDDO
!hpf$ independent(J,I)
      DO J=1,NM1
         DO I=1,MM1
            H(I,J) = P(I,J)+.25*(U(I+1,J)*U(I+1,J)+U(I,J)*U(I,J)
     1           +V(I,J+1)*V(I,J+1)+V(I,J)*V(I,J))
         ENDDO
      ENDDO

C *** PERIODIC CONTINUATION [110,115]

!hpf$ independent
      DO J=1,NM1
         CU(1,J) = CU(m,J)
      ENDDO
!hpf$ independent
      DO J=2,n
         CV(m,J) = CV(1,J)
      ENDDO
!hpf$ independent
      DO J=2,n
         Z(1,J) = Z(m,J)
      ENDDO
!hpf$ independent
      DO J=1,NM1
         H(m,J) = H(1,J)
      ENDDO

!hpf$ independent
      DO I=2,m
         CU(I,n) = CU(I,1)
      ENDDO
!hpf$ independent
      DO I=1,MM1
         CV(I,1) = CV(I,n)
      ENDDO
!hpf$ independent
      DO I=2,m
         Z(I,1) = Z(I,n)
      ENDDO
!hpf$ independent
      DO I=1,MM1
         H(I,n) = H(I,1)
      ENDDO

! corners exchange, could be a generalized shift iff 1d distribution
      CU(1,n) = CU(m,1)
      CV(m,1) = CV(1,n)
      Z(1,1) = Z(m,n)
      H(m,n) = H(1,1)

C *** COMPUTE NEW VALUES U, V, AND P [200]

      TDTS8 = TDT/8.
      TDTSDX = TDT/DX
      TDTSDY = TDT/DY

!hpf$ independent(J,I)
      DO J=1,NM1
         DO I=2,m
            UNEW(I,J) = UOLD(I,J)+
     1           TDTS8*(Z(I,J+1)+Z(I,J))*(CV(I,J+1)+CV(I-1,J+1)
     2           +CV(I-1,J)+CV(I,J))-TDTSDX*(H(I,J)-H(I-1,J))
         ENDDO
      ENDDO
!hpf$ independent(J,I)
      DO J=2,n
         DO I=1,MM1
            VNEW(I,J) = VOLD(I,J)-TDTS8*(Z(I+1,J)+Z(I,J))
     1           *(CU(I+1,J)+CU(I,J)+CU(I,J-1)+CU(I+1,J-1))
     2           -TDTSDY*(H(I,J)-H(I,J-1))
         ENDDO
      ENDDO
!hpf$ independent(J,I)
      DO J=1,NM1
         DO I=1,MM1
            PNEW(I,J) = POLD(I,J)-TDTSDX*(CU(I+1,J)-CU(I,J))
     1           -TDTSDY*(CV(I,J+1)-CV(I,J))
         ENDDO
      ENDDO

C *** PERIODIC CONTINUATION [210,215]

!hpf$ independent
      DO J=1,NM1
         UNEW(1,J) = UNEW(m,J)
      ENDDO
!hpf$ independent
      DO J=2,n
         VNEW(m,J) = VNEW(1,J)
      ENDDO
!hpf$ independent
      DO J=1,NM1
         PNEW(m,J) = PNEW(1,J)
      ENDDO

!hpf$ independent
      DO I=2,m
         UNEW(I,n) = UNEW(I,1)
      ENDDO
!hpf$ independent
      DO I=1,MM1
         VNEW(I,1) = VNEW(I,n)
      ENDDO
!hpf$ independent
      DO I=1,MM1
         PNEW(I,n) = PNEW(I,1)
      ENDDO

! corners again...
      UNEW(1,N+1) = UNEW(M+1,1)
      VNEW(M+1,1) = VNEW(1,N+1)
      PNEW(M+1,N+1) = PNEW(1,1)

C     IF(NCYCLE .GT. ITMAX) WRITE (*,220)
C 220 FORMAT('0   *****  END OF PROGRAM SHALLOW  *****')

      IF (NCYCLE.GT.ITMAX) THEN
         CLOSE(2)
! was STOP => HPFC coredump...
         GOTO 1000
      ENDIF

      TIME = TIME + DT

      IF(MOD(NCYCLE,MPRINT) .NE. 0) GO TO 370

      PTIME = TIME/3600.
C
C     WRITE(*,350) NCYCLE,PTIME
C 350 FORMAT(//,' CYCLE NUMBER',I5,' MODEL TIME IN  HOURS',F6.2)
C     WRITE(*,355) (PNEW(I,I),I=1,MNMIN)
C 355 FORMAT(/,' DIAGONAL ELEMENTS OF P ' //,(8E16.6))
C     WRITE(*,360) (UNEW(I,I),I=1,MNMIN)
C 360 FORMAT(/,' DIAGONAL ELEMENTS OF U ' //,(8E16.6))
C     WRITE(*,365) (VNEW(I,I),I=1,MNMIN)
C 365 FORMAT(/,' DIAGONAL ELEMENTS OF V ' //,(8E16.6))
C
      CALL PLOT (P,NCYCLE,LABEL(1))
      CALL PLOT (Z,NCYCLE,LABEL(4))
      CALL PLOT (H,NCYCLE,LABEL(5))
      CALL PLOT (U,NCYCLE,LABEL(2))
      CALL PLOT (V,NCYCLE,LABEL(3))
C
  370 IF(NCYCLE .LE. 1) GO TO 310

!loop 300
!hpf$ independent(J,I)
      DO J=1,NM1
         DO I=1,MM1
            UOLD(I,J) = U(I,J)+ALPHA*(UNEW(I,J)-2.*U(I,J)+UOLD(I,J))
            VOLD(I,J) = V(I,J)+ALPHA*(VNEW(I,J)-2.*V(I,J)+VOLD(I,J))
            POLD(I,J) = P(I,J)+ALPHA*(PNEW(I,J)-2.*P(I,J)+POLD(I,J))
            U(I,J) = UNEW(I,J)
            V(I,J) = VNEW(I,J)
            P(I,J) = PNEW(I,J)
         ENDDO
      ENDDO

C *** PERIODIC CONTINUATION

!loop 320
!hpf$ independent
      DO J=1,NM1
         UOLD(m,J) = UOLD(1,J)
      ENDDO
!hpf$ independent
      DO J=1,NM1
         VOLD(m,J) = VOLD(1,J)
      ENDDO
!hpf$ independent
      DO J=1,NM1
         POLD(m,J) = POLD(1,J)
      ENDDO
!hpf$ independent
      DO J=1,NM1
         U(m,J) = U(1,J)
      ENDDO
!hpf$ independent
      DO J=1,NM1
         V(m,J) = V(1,J)
      ENDDO
!hpf$ independent
      DO J=1,NM1
         P(m,J) = P(1,J)
      ENDDO

!loop 325
!hpf$ independent
      DO I=1,MM1
         UOLD(I,n) = UOLD(I,1)
      ENDDO
!hpf$ independent
      DO I=1,MM1
         VOLD(I,n) = VOLD(I,1)
      ENDDO
!hpf$ independent
      DO I=1,MM1
         POLD(I,n) = POLD(I,1)
      ENDDO
!hpf$ independent
      DO I=1,MM1
         U(I,n) = U(I,1)
      ENDDO
!hpf$ independent
      DO I=1,MM1
         V(I,n) = V(I,1)
      ENDDO
!hpf$ independent
      DO I=1,MM1
         P(I,n) = P(I,1)
      ENDDO

! corners...
      UOLD(m,n) = UOLD(1,1)
      VOLD(m,n) = VOLD(1,1)
      POLD(m,n) = POLD(1,1)
      U(m,n) = U(1,1)
      V(m,n) = V(1,1)
      P(m,n) = P(1,1)

!loop
      GO TO 90

  310 TDT = TDT+TDT

! loop 400 (should be a size-3 flip-flop!)
!hpf$ independent(J,I)
      DO J=1,n
         DO I=1,m
            UOLD(I,J) = U(I,J)
            VOLD(I,J) = V(I,J)
            POLD(I,J) = P(I,J)
            U(I,J) = UNEW(I,J)
            V(I,J) = VNEW(I,J)
            P(I,J) = PNEW(I,J)
         ENDDO
      ENDDO

      GO TO 90

 1000 CONTINUE

      END
C
      SUBROUTINE PLOT (FIELD,NCYCLE,FTITLE)
C
C *** SUBROUTINE TO MAKE TWO-DIMENSIONAL PLOTS OF FIELDS
C
      integer m,n
      parameter(m=320,n=200)
      REAL FIELD (m,n)

!hpf$ processors procs(2,2)
!hpf$ distribute (block,block) onto procs:: FIELD

      integer I,J,ICOLOR
      real top,bottom,scale

      CHARACTER*16 FTITLE
      CHARACTER*1 IMAGE(m,n),LOOKUP(16)
      DATA LOOKUP/'A','B','C','D','E','F','G','H',
     1            'I','J','K','L','M','N','O','P'/

!hpf$ align with FIELD:: IMAGE

      WRITE(2) FTITLE,NCYCLE

      CALL RANGE(FIELD,TOP,BOTTOM)
      SCALE = TOP-BOTTOM

! loop 801
!hpf$ independent(J,I), new(ICOLOR)
      DO J=1,n
         DO I=1,m
            ICOLOR = ((FIELD(I,J)-BOTTOM)/SCALE)*16.0
            IMAGE(I,J) = LOOKUP(ICOLOR + 1)
         ENDDO
      ENDDO
C
C * INSERT A SCALE OF COLORS ALONG THE SIDE OF THE IMAGE
C
! loop 802-803
!hpf$ independent(I,J), new(ICOLOR)
      DO I=20,169
         ICOLOR = (I-10)/10
         DO J=1,20
            IMAGE(J,I)=LOOKUP(ICOLOR)
         ENDDO
      ENDDO

C
C * WRITE THE IMAGE TO THE OUTPUT FILE [804]
C
      DO J=1,n
         WRITE(2) (IMAGE(I,J),I=1,m)
      ENDDO
C
      RETURN
C
      END
C
      SUBROUTINE RANGE(FIELD,TOP,BOTTOM)

      integer n,m
      parameter (m=320,n=200)

      REAL FIELD(m,n), TOP, BOTTOM

!hpf$ processors procs(2,2)
!hpf$ distribute (block,block) onto procs:: FIELD

      TOP = FIELD(1,1)
      BOTTOM = FIELD(1,1)
! loop 901
!hpf$ independent(J,I), reduction(BOTTOM,TOP)
      DO J=1,n
         DO I=1,m
            BOTTOM=MIN(FIELD(I,J),BOTTOM)
            TOP=MAX(FIELD(I,J),TOP)
         ENDDO
      ENDDO
C
      RETURN
C
      END


c    idx2(n1,n2) -> N; ni >=0

      integer function idx2(n1,n2)
      IMPLICIT NONE
      integer n1,n2,nx,sum

      if ((n1<0).or.(n2<0))then
       idx2=0
       return
      endif

       nx  = n1
       sum = nx+1
       nx  = nx+n2
       sum = sum + (nx*(1 + nx))/2

       idx2 = sum

       return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccc
c    idx3(n1,n2,n3) -> N; ni >=0

      integer function idx3(n1,n2,n3)
      IMPLICIT NONE
      integer n1,n2,n3,nx,sum

      if ((n1<0).or.(n2<0).or.(n3<0))then
       idx3=0
       return
      endif

       nx  = n1
       sum = nx+1
       nx  = nx+n2
       sum = sum + (nx*(1 + nx))/2
       nx  = nx+n3
       sum = sum + (nx*(1 + nx)*(2 + nx))/6

       idx3 = sum

       return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccc
c    idx5(n1,n2,n3,n4,n5) -> N; ni >=0

      integer function idx5(n1,n2,n3,n4,n5)
      IMPLICIT NONE
      integer n1,n2,n3,n4,n5,nx,sum

      if ((n1<0).or.(n2<0).or.(n3<0).or.(n4<0).or.(n5<0))then
       idx5=0
       return
      endif

       nx  = n1
       sum = nx+1
       nx  = nx+n2
       sum = sum + (nx*(1 + nx))/2
       nx  = nx+n3
       sum = sum + (nx*(1 + nx)*(2 + nx))/6
       nx  = nx+n4
       sum = sum + (nx*(1 + nx)*(2 + nx)*(3 + nx))/24
       nx  = nx+n5
       sum = sum + (nx*(1 + nx)*(2 + nx)*(3 + nx)*(4 + nx))/120

       idx5 = sum

       return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccc
c    idx6(n1,n2,n3,n4,n5,n6) -> N; ni >=0

      integer function idx6(n1,n2,n3,n4,n5,n6)
      USE PRMTS
      IMPLICIT NONE
      integer n1,n2,n3,n4,n5,n6,nx,sum

      if ((n1>-1).and.(n2>-1).and.(n3>-1).and.(n4>-1).and.(n5>-1).and.(n6>-1)) then
       nx  = n1
       sum = nx+1
       nx  = nx+n2
       sum = sum + (nx*(1 + nx))/2
       nx  = nx+n3
       sum = sum + (nx*(1 + nx)*(2 + nx))/6
       nx  = nx+n4
       sum = sum + (nx*(1 + nx)*(2 + nx)*(3 + nx))/24
       nx  = nx+n5
       sum = sum + (nx*(1 + nx)*(2 + nx)*(3 + nx)*(4 + nx))/120
       nx  = nx+n6
       sum = sum + (nx*(1 + nx)*(2 + nx)*(3 + nx)*(4 + nx)*(5 + nx))/720
       idx6= sum
       return
      endif

      IF (SWITCH.EQ.0) THEN
       idx6 = 0
       RETURN
      ENDIF

      if((n1.eq.-1).and.(n2>-1).and.(n3>-1).and.(n4>-1).and.(n5>-1).and.(n6>-1)) then
       nx  = n2
       sum = nx+1
       nx  = nx+n3
       sum = sum + (nx*(1 + nx))/2
       nx  = nx+n4
       sum = sum + (nx*(1 + nx)*(2 + nx))/6
       nx  = nx+n5
       sum = sum + (nx*(1 + nx)*(2 + nx)*(3 + nx))/24
       nx  = nx+n6
       sum = sum + (nx*(1 + nx)*(2 + nx)*(3 + nx)*(4 + nx))/120
       idx6= MAXFN+sum
       return
      endif

      if((n1>-1).and.(n2.eq.-1).and.(n3>-1).and.(n4>-1).and.(n5>-1).and.(n6>-1)) then
       nx  = n1
       sum = nx+1
       nx  = nx+n3
       sum = sum + (nx*(1 + nx))/2
       nx  = nx+n4
       sum = sum + (nx*(1 + nx)*(2 + nx))/6
       nx  = nx+n5
       sum = sum + (nx*(1 + nx)*(2 + nx)*(3 + nx))/24
       nx  = nx+n6
       sum = sum + (nx*(1 + nx)*(2 + nx)*(3 + nx)*(4 + nx))/120
       idx6= MAXFN+MAXFM+sum
       return
      endif

      if((n1>-1).and.(n2>-1).and.(n3.eq.-1).and.(n4>-1).and.(n5>-1).and.(n6>-1)) then
       nx  = n1
       sum = nx+1
       nx  = nx+n2
       sum = sum + (nx*(1 + nx))/2
       nx  = nx+n4
       sum = sum + (nx*(1 + nx)*(2 + nx))/6
       nx  = nx+n5
       sum = sum + (nx*(1 + nx)*(2 + nx)*(3 + nx))/24
       nx  = nx+n6
       sum = sum + (nx*(1 + nx)*(2 + nx)*(3 + nx)*(4 + nx))/120
       idx6= MAXFN+2*MAXFM+sum
       return
      endif

      if((n1>-1).and.(n2>-1).and.(n3>-1).and.(n4.eq.-1).and.(n5>-1).and.(n6>-1)) then
       nx  = n1
       sum = nx+1
       nx  = nx+n2
       sum = sum + (nx*(1 + nx))/2
       nx  = nx+n3
       sum = sum + (nx*(1 + nx)*(2 + nx))/6
       nx  = nx+n5
       sum = sum + (nx*(1 + nx)*(2 + nx)*(3 + nx))/24
       nx  = nx+n6
       sum = sum + (nx*(1 + nx)*(2 + nx)*(3 + nx)*(4 + nx))/120
       idx6= MAXFN+3*MAXFM+sum
       return
      endif

      if((n1>-1).and.(n2>-1).and.(n3>-1).and.(n4>-1).and.(n5.eq.-1).and.(n6>-1)) then
       nx  = n1
       sum = nx+1
       nx  = nx+n2
       sum = sum + (nx*(1 + nx))/2
       nx  = nx+n3
       sum = sum + (nx*(1 + nx)*(2 + nx))/6
       nx  = nx+n4
       sum = sum + (nx*(1 + nx)*(2 + nx)*(3 + nx))/24
       nx  = nx+n6
       sum = sum + (nx*(1 + nx)*(2 + nx)*(3 + nx)*(4 + nx))/120
       idx6= MAXFN+4*MAXFM+sum
       return
      endif

      if((n1>-1).and.(n2>-1).and.(n3>-1).and.(n4>-1).and.(n5>-1).and.(n6.eq.-1)) then
       nx  = n1
       sum = nx+1
       nx  = nx+n2
       sum = sum + (nx*(1 + nx))/2
       nx  = nx+n3
       sum = sum + (nx*(1 + nx)*(2 + nx))/6
       nx  = nx+n4
       sum = sum + (nx*(1 + nx)*(2 + nx)*(3 + nx))/24
       nx  = nx+n5
       sum = sum + (nx*(1 + nx)*(2 + nx)*(3 + nx)*(4 + nx))/120
       idx6= MAXFN+5*MAXFM+sum
       return
      endif

      IF (SWITCH.EQ.1) THEN
       idx6 = 0
       RETURN
      ENDIF

      if((n1.eq.-2).and.(n2>-1).and.(n3>-1).and.(n4>-1).and.(n5>-1).and.(n6>-1)) then
       nx  = n2
       sum = nx+1
       nx  = nx+n3
       sum = sum + (nx*(1 + nx))/2
       nx  = nx+n4
       sum = sum + (nx*(1 + nx)*(2 + nx))/6
       nx  = nx+n5
       sum = sum + (nx*(1 + nx)*(2 + nx)*(3 + nx))/24
       nx  = nx+n6
       sum = sum + (nx*(1 + nx)*(2 + nx)*(3 + nx)*(4 + nx))/120
       idx6= MAXFN+6*MAXFM+sum
       return
      endif

      if((n1>-1).and.(n2.eq.-2).and.(n3>-1).and.(n4>-1).and.(n5>-1).and.(n6>-1)) then
       nx  = n1
       sum = nx+1
       nx  = nx+n3
       sum = sum + (nx*(1 + nx))/2
       nx  = nx+n4
       sum = sum + (nx*(1 + nx)*(2 + nx))/6
       nx  = nx+n5
       sum = sum + (nx*(1 + nx)*(2 + nx)*(3 + nx))/24
       nx  = nx+n6
       sum = sum + (nx*(1 + nx)*(2 + nx)*(3 + nx)*(4 + nx))/120
       idx6= MAXFN+7*MAXFM+sum
       return
      endif

      if((n1>-1).and.(n2>-1).and.(n3.eq.-2).and.(n4>-1).and.(n5>-1).and.(n6>-1)) then
       nx  = n1
       sum = nx+1
       nx  = nx+n2
       sum = sum + (nx*(1 + nx))/2
       nx  = nx+n4
       sum = sum + (nx*(1 + nx)*(2 + nx))/6
       nx  = nx+n5
       sum = sum + (nx*(1 + nx)*(2 + nx)*(3 + nx))/24
       nx  = nx+n6
       sum = sum + (nx*(1 + nx)*(2 + nx)*(3 + nx)*(4 + nx))/120
       idx6= MAXFN+8*MAXFM+sum
       return
      endif

      if((n1>-1).and.(n2>-1).and.(n3>-1).and.(n4.eq.-2).and.(n5>-1).and.(n6>-1)) then
       nx  = n1
       sum = nx+1
       nx  = nx+n2
       sum = sum + (nx*(1 + nx))/2
       nx  = nx+n3
       sum = sum + (nx*(1 + nx)*(2 + nx))/6
       nx  = nx+n5
       sum = sum + (nx*(1 + nx)*(2 + nx)*(3 + nx))/24
       nx  = nx+n6
       sum = sum + (nx*(1 + nx)*(2 + nx)*(3 + nx)*(4 + nx))/120
       idx6= MAXFN+9*MAXFM+sum
       return
      endif

      if((n1>-1).and.(n2>-1).and.(n3>-1).and.(n4>-1).and.(n5.eq.-2).and.(n6>-1)) then
       nx  = n1
       sum = nx+1
       nx  = nx+n2
       sum = sum + (nx*(1 + nx))/2
       nx  = nx+n3
       sum = sum + (nx*(1 + nx)*(2 + nx))/6
       nx  = nx+n4
       sum = sum + (nx*(1 + nx)*(2 + nx)*(3 + nx))/24
       nx  = nx+n6
       sum = sum + (nx*(1 + nx)*(2 + nx)*(3 + nx)*(4 + nx))/120
       idx6= MAXFN+10*MAXFM+sum
       return
      endif

      if((n1>-1).and.(n2>-1).and.(n3>-1).and.(n4>-1).and.(n5>-1).and.(n6.eq.-2)) then
       nx  = n1
       sum = nx+1
       nx  = nx+n2
       sum = sum + (nx*(1 + nx))/2
       nx  = nx+n3
       sum = sum + (nx*(1 + nx)*(2 + nx))/6
       nx  = nx+n4
       sum = sum + (nx*(1 + nx)*(2 + nx)*(3 + nx))/24
       nx  = nx+n5
       sum = sum + (nx*(1 + nx)*(2 + nx)*(3 + nx)*(4 + nx))/120
       idx6= MAXFN+11*MAXFM+sum
       return
      endif

      idx6 = 0
      return
      end

cccccccccccccccccccccccccccccccccccccccccccccccccccc

!      real (16) function delta(n)
!      IMPLICIT NONE
!       integer n
!       if (n==0) then
!        delta=1.0q0
!       else
!        delta=0.0q0
!       endif
!       return
!      end

cccccccccccccccccccccccccccccccccccccccccccccccccccc


module m_juDFT_round
contains
   function round_to_deci(x, n) result(rounded_x)
      !rounds to the n-th decimal point
      implicit none
      real, intent(in)    :: x
      integer, intent(in) :: n
      real                :: deci_shift, rounded_x

      deci_shift = 10**n
      rounded_x = real(NINT(x * deci_shift ) / deci_shift)
   end function round_to_deci
end module m_juDFT_round


module profiles

use constants

implicit none

real(kind=dbl) :: omgrf
real(kind=dbl), allocatable, dimension(:) :: mSpec, qSpec, tSpec, dSpec
real(kind=dbl), allocatable, dimension(:) :: zSpec, amuSpec
real(kind=dbl), allocatable, dimension(:,:,:) :: &
    omgc, omgp2
real, allocatable, dimension(:) :: &
    tLim, dLim, dAlpha, dBeta, tAlpha, tBeta

contains

    function interp1d(xArr,yArr,x)

        implicit none

        real, intent(in) :: xArr(:), x
        complex, intent(in) :: yArr(:)

        integer :: n, iL, iR
        real :: i_
        complex :: interp1d

        n = size(xArr)

        i_ = (x-xArr(1))/(xArr(n)-xArr(1))*real(n-1.0)+1.0
        iL = floor(i_)
        iR = ceiling(i_)
        if(iL.lt.1)then
                write(*,*) 'ERROR 1', i_, iL, iR
        endif
        if(iR.gt.n)then
                write(*,*) 'ERROR 2', i_, iL, iR
        endif

        if(iL.eq.iR)then
            interp1d = yArr(iR)
        else
            interp1d = yArr(iL) + (yArr(iR)-yArr(iL)) * (x - xArr(iL)) / (xArr(iR)-xArr(iL))
        endif

    end function interp1d

    subroutine init_JpFromFile( g )

        use read_jp_from_file, only: &
            file_nS=>nS, file_nR=>nR, file_nZ=>nZ, file_r=>r, file_z=>z, &
            file_Jp_r=>Jp_r, file_Jp_t=>Jp_t, file_Jp_z=>Jp_z!, &
            !file_Jp_r_s=>Jp_r_s, file_Jp_t_s=>Jp_t_s, file_Jp_z_s=>Jp_z_s

        use aorsaNameList, only: nSpec
        use grid
        use parallel, only: iAm
        use fitpack

        implicit none

        type(gridBlock), intent(inout) :: g

        real, allocatable :: Tmp2DArr_re(:,:),Tmp2DArr_im(:,:)

        integer :: islpsw, iErr, i, j, s, w
        real, allocatable :: temp(:), temp_im(:)
        real, allocatable :: zx1(:), zxm(:), zy1(:), zyn(:)
        real :: zxy11, zxym1, zxy1n, zxymn

        real, allocatable :: zx1_im(:), zxm_im(:), zy1_im(:), zyn_im(:)
        real :: zxy11_im, zxym1_im, zxy1n_im, zxymn_im

        real, allocatable :: zp_tmp(:), zp_tmp_im(:)
        real :: sigma_dp
        real, allocatable :: file_r_dp(:), file_z_dp(:)
        real :: ThisR,ThisZ
        real :: re_, im_, i_
        integer :: iL, iR

        if(.not.allocated(g%file_JpR))allocate ( &
            g%file_JpR(g%nR,g%nZ), &
            g%file_JpT(g%nR,g%nZ), &
            g%file_JpZ(g%nR,g%nZ) )

        if(file_nZ.gt.1)then

            sigma_dp = 1.0
            islpsw  = 255

            allocate(temp(file_nZ+file_nZ+file_nR))
            allocate(zp_tmp(3*file_nZ*file_nR) )
            allocate(zx1(file_nZ), zxm(file_nZ), zy1(file_nR), zyn(file_nR))

            allocate(temp_im(file_nZ+file_nZ+file_nR))
            allocate(zp_tmp_im(3*file_nZ*file_nR) )
            allocate(zx1_im(file_nZ), zxm_im(file_nZ), zy1_im(file_nR), zyn_im(file_nR))

            allocate(Tmp2DArr_re(file_nR,file_nZ), Tmp2DArr_im(file_nR,file_nZ))
            allocate(file_r_dp(file_nR),file_z_dp(file_nZ))

            file_r_dp = file_r
            file_z_dp = file_z

            Tmp2DArr_re = real(real(file_Jp_r))
            call surf1 ( file_nR, file_nZ, file_r, file_z, Tmp2DArr_re, file_nR, zx1, zxm, &
                zy1, zyn, zxy11, zxym1, zxy1n, zxymn, islpsw, &
                zp_tmp, temp, sigma_dp, iErr)

            Tmp2DArr_im = real(aimag(file_Jp_r))
            call surf1 ( file_nR, file_nZ, file_r_dp, file_z_dp, Tmp2DArr_im, file_nR, zx1_im, zxm_im, &
                zy1_im, zyn_im, zxy11_im, zxym1_im, zxy1n_im, zxymn_im, islpsw, &
                zp_tmp_im, temp_im, sigma_dp, iErr)

            do i=1,g%nR
                do j=1,g%nZ

                    ThisR = g%r(i)
                    ThisZ = g%z(j)

                    re_ = surf2 ( ThisR, ThisZ, file_nR, file_nZ, file_r, file_z, &
                        Tmp2DArr_re, file_nR, zp_tmp, sigma_dp )
                    im_ = surf2 ( ThisR, ThisZ, file_nR, file_nZ, file_r_dp, file_z_dp, &
                        Tmp2DArr_im, file_nR, zp_tmp_im, sigma_dp )

                    g%file_JpR(i,j) = cmplx(re_,im_)

                    write(*,*) ThisR, ThisZ, g%file_JpR(i,j), re_, im_

                enddo
            enddo

        else

            do i=1,g%nR

                    ThisR = g%r(i)

                    g%file_JpR(i,1) = interp1d(file_r,file_Jp_r(:,1),ThisR)
                    g%file_JpT(i,1) = interp1d(file_r,file_Jp_t(:,1),ThisR)
                    g%file_JpZ(i,1) = interp1d(file_r,file_Jp_z(:,1),ThisR)

            enddo

        endif

    end subroutine init_JpFromFile

    subroutine init_AR2_Profiles( g )

        use AR2Input, only: &
            ar2_nS=>nS,ar2_amu=>amu,ar2_AtomicZ=>AtomicZ, &
            ar2_nR=>nR, ar2_nZ=>nZ, ar2_r=>r, ar2_z=>z, &
            Density_m3, Temp_eV, nuOmg, jant_r, jant_t, jant_z
        use grid
        use aorsaNameList, only: &
            nSpec,freqcy,dampVacuumWave
        use parallel, only: iAm

        use fitpack

        implicit none

        type(gridBlock), intent(inout) :: g

        real, allocatable :: Tmp2DArr(:,:)

        integer :: islpsw, iErr, i, j, s, w
        real, allocatable :: temp(:)
        real, allocatable :: zx1(:), zxm(:), zy1(:), zyn(:)
        real :: zxy11, zxym1, zxy1n, zxymn

        real, allocatable :: zp_tmp(:)
        real :: sigma_dp
        real, allocatable :: ar2_r_dp(:), ar2_z_dp(:)
        real :: ThisR,ThisZ

        sigma_dp = 1.0
        islpsw  = 255

        allocate(temp(ar2_nZ+ar2_nZ+ar2_nR))
        allocate(zp_tmp(3*ar2_nZ*ar2_nR) )
        allocate(zx1(ar2_nZ), zxm(ar2_nZ), zy1(ar2_nR), zyn(ar2_nR))
        allocate(Tmp2DArr(ar2_nR,ar2_nZ))
        allocate(ar2_r_dp(ar2_nR),ar2_z_dp(ar2_nZ))

        ar2_r_dp = ar2_r
        ar2_z_dp = ar2_z

        ! At present these two lines are duplicates of the
        ! init_profiles() routine below. This is not nice
        ! and I should change it to get done somewhere else.

        omgrf = 2.0 * pi * freqcy

        allocate ( &
            mSpec(nSpec), zSpec(nSpec), &
            qSpec(nSpec), amuSpec(nSpec) )

        amuSpec = ar2_amu
        zSpec = ar2_AtomicZ

        mSpec       = amuSpec * const_amu
        qSpec       = zSpec * q

        allocate ( &
            g%densitySpec (size(g%pt), nSpec ), &
            g%ktSpec (size(g%pt), nSpec ), &
            g%nuOmg(size(g%pt), nSpec), &
            g%k0(size(g%pt)) )

        do s=1,nSpec

            do w=1,size(g%pt)
                i=g%pt(w)%i
                j=g%pt(w)%j

                ThisR = g%r(i)
                ThisZ = g%z(j)

                g%DensitySpec(w,s) = Density_m3(i,j,s)
                g%kTSpec(w,s) = Temp_eV(i,j,s)
                g%nuOmg(w,s) = nuOmg(i,j,s)

            enddo

        enddo

        do w=1,size(g%pt)

            if(dampVacuumWave)then ! Useful for EC frequency problems where damping Jp doesn't kill the vacuum wave.

                g%k0(w) = (omgrf + complex(0,1)*g%nuOmg(w,1)*omgrf) / clight

            else

                g%k0(w) = omgrf / clight

            endif

        enddo

        ! JAnt interpolation

        if(.not.allocated(g%jR))allocate ( &
            g%jR(g%nR,g%nZ), &
            g%jT(g%nR,g%nZ), &
            g%jZ(g%nR,g%nZ) )

        do i=1,g%nR
            do j=1,g%nZ
                ThisR = g%r(i)
                ThisZ = g%z(j)
                g%jR(i,j) = jant_r(i,j)
                g%jT(i,j) = jant_t(i,j)
                g%jZ(i,j) = jant_z(i,j)
            enddo
        enddo

        ! Santiy checking

        if(count(g%kTSpec<=0)>0)then
                write(*,*) 'ERROR: -ve temp'
                write(*,*) '    This is possibly due to a bad interpolation.'
                write(*,*) '    Try creating the ar2Input file with higher res.'
                write(*,*) '    Really need to fix this crap.'
                stop
        endif

        if(count(g%DensitySpec<=0)>0)then
                write(*,*) 'ERROR: -ve density'
                write(*,*) '    This is possibly due to a bad interpolation.'
                write(*,*) '    Try creating the ar2Input file with higher res.'
                write(*,*) '    Really need to fix this crap.'
                stop
        endif

        if(count(g%nuOmg<0)>0)then
                where(g%nuOmg<0.0) g%nuOmg = 0.0
        endif

        call omega_freqs ( g )

    end subroutine init_AR2_Profiles

    subroutine omega_freqs ( g )

        use aorsaNamelist, &
            only: nSpec
        use bField
        use grid

        implicit none

        type(gridBlock), intent(inout) :: g

        integer :: i, j, w

        !   calculate the cyclotron and plasma freqs
        !   ----------------------------------------

        allocate ( &
            g%omgc ( size(g%pt), nSpec ), &
            g%omgp2 ( size(g%pt), nSpec ) )

        do w=1,size(g%pt)
            i=g%pt(w)%i
            j=g%pt(w)%j

                g%omgc(w,:) = qSpec * g%bMag(w) / mSpec
                g%omgp2(w,:)    = g%densitySpec(w,:) * qSpec**2 / ( eps0 * mSpec )

        enddo

    end subroutine omega_freqs

end module profiles


*DECK DRC3JM
      SUBROUTINE DRC3JM (L1, L2, L3, M1, M2MIN, M2MAX, THRCOF, NDIM,
     +   IER)
C***BEGIN PROLOGUE  DRC3JM
C***PURPOSE  Evaluate the 3j symbol g(M2) = (L1 L2   L3  )
C                                           (M1 M2 -M1-M2)
C            for all allowed values of M2, the other parameters
C            being held fixed.
C***LIBRARY   SLATEC
C***CATEGORY  C19
C***TYPE      DOUBLE PRECISION (RC3JM-S, DRC3JM-D)
C***KEYWORDS  3J COEFFICIENTS, 3J SYMBOLS, CLEBSCH-GORDAN COEFFICIENTS,
C             RACAH COEFFICIENTS, VECTOR ADDITION COEFFICIENTS,
C             WIGNER COEFFICIENTS
C***AUTHOR  Gordon, R. G., Harvard University
C           Schulten, K., Max Planck Institute
C***DESCRIPTION
C
C *Usage:
C
C        DOUBLE PRECISION L1, L2, L3, M1, M2MIN, M2MAX, THRCOF(NDIM)
C        INTEGER NDIM, IER
C
C        CALL DRC3JM (L1, L2, L3, M1, M2MIN, M2MAX, THRCOF, NDIM, IER)
C
C *Arguments:
C
C     L1 :IN      Parameter in 3j symbol.
C
C     L2 :IN      Parameter in 3j symbol.
C
C     L3 :IN      Parameter in 3j symbol.
C
C     M1 :IN      Parameter in 3j symbol.
C
C     M2MIN :OUT  Smallest allowable M2 in 3j symbol.
C
C     M2MAX :OUT  Largest allowable M2 in 3j symbol.
C
C     THRCOF :OUT Set of 3j coefficients generated by evaluating the
C                 3j symbol for all allowed values of M2.  THRCOF(I)
C                 will contain g(M2MIN+I-1), I=1,2,...,M2MAX-M2MIN+1.
C
C     NDIM :IN    Declared length of THRCOF in calling program.
C
C     IER :OUT    Error flag.
C                 IER=0 No errors.
C                 IER=1 Either L1.LT.ABS(M1) or L1+ABS(M1) non-integer.
C                 IER=2 ABS(L1-L2).LE.L3.LE.L1+L2 not satisfied.
C                 IER=3 L1+L2+L3 not an integer.
C                 IER=4 M2MAX-M2MIN not an integer.
C                 IER=5 M2MAX less than M2MIN.
C                 IER=6 NDIM less than M2MAX-M2MIN+1.
C
C *Description:
C
C     Although conventionally the parameters of the vector addition
C  coefficients satisfy certain restrictions, such as being integers
C  or integers plus 1/2, the restrictions imposed on input to this
C  subroutine are somewhat weaker. See, for example, Section 27.9 of
C  Abramowitz and Stegun or Appendix C of Volume II of A. Messiah.
C  The restrictions imposed by this subroutine are
C       1. L1.GE.ABS(M1) and L1+ABS(M1) must be an integer;
C       2. ABS(L1-L2).LE.L3.LE.L1+L2;
C       3. L1+L2+L3 must be an integer;
C       4. M2MAX-M2MIN must be an integer, where
C          M2MAX=MIN(L2,L3-M1) and M2MIN=MAX(-L2,-L3-M1).
C  If the conventional restrictions are satisfied, then these
C  restrictions are met.
C
C     The user should be cautious in using input parameters that do
C  not satisfy the conventional restrictions. For example, the
C  the subroutine produces values of
C       g(M2) = (0.75 1.50   1.75  )
C               (0.25  M2  -0.25-M2)
C  for M2=-1.5,-0.5,0.5,1.5 but none of the symmetry properties of the
C  3j symbol, set forth on page 1056 of Messiah, is satisfied.
C
C     The subroutine generates g(M2MIN), g(M2MIN+1), ..., g(M2MAX)
C  where M2MIN and M2MAX are defined above. The sequence g(M2) is
C  generated by a three-term recurrence algorithm with scaling to
C  control overflow. Both backward and forward recurrence are used to
C  maintain numerical stability. The two recurrence sequences are
C  matched at an interior point and are normalized from the unitary
C  property of 3j coefficients and Wigner's phase convention.
C
C    The algorithm is suited to applications in which large quantum
C  numbers arise, such as in molecular dynamics.
C
C***REFERENCES  1. Abramowitz, M., and Stegun, I. A., Eds., Handbook
C                  of Mathematical Functions with Formulas, Graphs
C                  and Mathematical Tables, NBS Applied Mathematics
C                  Series 55, June 1964 and subsequent printings.
C               2. Messiah, Albert., Quantum Mechanics, Volume II,
C                  North-Holland Publishing Company, 1963.
C               3. Schulten, Klaus and Gordon, Roy G., Exact recursive
C                  evaluation of 3j and 6j coefficients for quantum-
C                  mechanical coupling of angular momenta, J Math
C                  Phys, v 16, no. 10, October 1975, pp. 1961-1970.
C               4. Schulten, Klaus and Gordon, Roy G., Semiclassical
C                  approximations to 3j and 6j coefficients for
C                  quantum-mechanical coupling of angular momenta,
C                  J Math Phys, v 16, no. 10, October 1975,
C                  pp. 1971-1988.
C               5. Schulten, Klaus and Gordon, Roy G., Recursive
C                  evaluation of 3j and 6j coefficients, Computer
C                  Phys Comm, v 11, 1976, pp. 269-278.
C***ROUTINES CALLED  D1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   750101  DATE WRITTEN
C   880515  SLATEC prologue added by G. C. Nielson, NBS; parameters
C           HUGE and TINY revised to depend on D1MACH.
C   891229  Prologue description rewritten; other prologue sections
C           revised; MMATCH (location of match point for recurrences)
C           removed from argument list; argument IER changed to serve
C           only as an error flag (previously, in cases without error,
C           it returned the number of scalings); number of error codes
C           increased to provide more precise error information;
C           program comments revised; SLATEC error handler calls
C           introduced to enable printing of error messages to meet
C           SLATEC standards. These changes were done by D. W. Lozier,
C           M. A. McClain and J. M. Smith of the National Institute
C           of Standards and Technology, formerly NBS.
C   910415  Mixed type expressions eliminated; variable C1 initialized;
C           description of THRCOF expanded. These changes were done by
C           D. W. Lozier.
C***END PROLOGUE  DRC3JM
C
      INTEGER NDIM, IER
      DOUBLE PRECISION L1, L2, L3, M1, M2MIN, M2MAX, THRCOF(NDIM)
C
      INTEGER I, INDEX, LSTEP, N, NFIN, NFINP1, NFINP2, NFINP3, NLIM,
     +        NSTEP2
      DOUBLE PRECISION A1, A1S, C1, C1OLD, C2, CNORM, D1MACH, DV, EPS,
     +                 HUGE, M2, M3, NEWFAC, OLDFAC, ONE, RATIO, SIGN1,
     +                 SIGN2, SRHUGE, SRTINY, SUM1, SUM2, SUMBAC,
     +                 SUMFOR, SUMUNI, THRESH, TINY, TWO, X, X1, X2, X3,
     +                 Y, Y1, Y2, Y3, ZERO
C
      DATA  ZERO,EPS,ONE,TWO /0.0D0,0.01D0,1.0D0,2.0D0/
C
C***FIRST EXECUTABLE STATEMENT  DRC3JM
      IER=0
C  HUGE is the square root of one twentieth of the largest floating
C  point number, approximately.
      HUGE = SQRT(D1MACH(2)/20.0D0)
      SRHUGE = SQRT(HUGE)
      TINY = 1.0D0/HUGE
      SRTINY = 1.0D0/SRHUGE
C
C     MMATCH = ZERO
C
C
C  Check error conditions 1, 2, and 3.
      IF((L1-ABS(M1)+EPS.LT.ZERO).OR.
     +   (MOD(L1+ABS(M1)+EPS,ONE).GE.EPS+EPS))THEN
         IER=1
         CALL XERMSG('SLATEC','DRC3JM','L1-ABS(M1) less than zero or '//
     +      'L1+ABS(M1) not integer.',IER,1)
         RETURN
      ELSEIF((L1+L2-L3.LT.-EPS).OR.(L1-L2+L3.LT.-EPS).OR.
     +   (-L1+L2+L3.LT.-EPS))THEN
         IER=2
         CALL XERMSG('SLATEC','DRC3JM','L1, L2, L3 do not satisfy '//
     +      'triangular condition.',IER,1)
         RETURN
      ELSEIF(MOD(L1+L2+L3+EPS,ONE).GE.EPS+EPS)THEN
         IER=3
         CALL XERMSG('SLATEC','DRC3JM','L1+L2+L3 not integer.',IER,1)
         RETURN
      ENDIF
C
C
C  Limits for M2
      M2MIN = MAX(-L2,-L3-M1)
      M2MAX = MIN(L2,L3-M1)
C
C  Check error condition 4.
      IF(MOD(M2MAX-M2MIN+EPS,ONE).GE.EPS+EPS)THEN
         IER=4
         CALL XERMSG('SLATEC','DRC3JM','M2MAX-M2MIN not integer.',IER,1)
         RETURN
      ENDIF
      IF(M2MIN.LT.M2MAX-EPS)   GO TO 20
      IF(M2MIN.LT.M2MAX+EPS)   GO TO 10
C
C  Check error condition 5.
      IER=5
      CALL XERMSG('SLATEC','DRC3JM','M2MIN greater than M2MAX.',IER,1)
      RETURN
C
C
C  This is reached in case that M2 and M3 can take only one value.
   10 CONTINUE
C     MSCALE = 0
      THRCOF(1) = (-ONE) ** INT(ABS(L2-L3-M1)+EPS) /
     1 SQRT(L1+L2+L3+ONE)
      RETURN
C
C  This is reached in case that M1 and M2 take more than one value.
   20 CONTINUE
C     MSCALE = 0
      NFIN = INT(M2MAX-M2MIN+ONE+EPS)
      IF(NDIM-NFIN)   21, 23, 23
C
C  Check error condition 6.
   21 IER = 6
      CALL XERMSG('SLATEC','DRC3JM','Dimension of result array for '//
     +            '3j coefficients too small.',IER,1)
      RETURN
C
C
C
C  Start of forward recursion from M2 = M2MIN
C
   23 M2 = M2MIN
      THRCOF(1) = SRTINY
      NEWFAC = 0.0D0
      C1 = 0.0D0
      SUM1 = TINY
C
C
      LSTEP = 1
   30 LSTEP = LSTEP + 1
      M2 = M2 + ONE
      M3 = - M1 - M2
C
C
      OLDFAC = NEWFAC
      A1 = (L2-M2+ONE) * (L2+M2) * (L3+M3+ONE) * (L3-M3)
      NEWFAC = SQRT(A1)
C
C
      DV = (L1+L2+L3+ONE)*(L2+L3-L1) - (L2-M2+ONE)*(L3+M3+ONE)
     1                               - (L2+M2-ONE)*(L3-M3-ONE)
C
      IF(LSTEP-2)  32, 32, 31
C
   31 C1OLD = ABS(C1)
   32 C1 = - DV / NEWFAC
C
      IF(LSTEP.GT.2)   GO TO 60
C
C
C  If M2 = M2MIN + 1, the third term in the recursion equation vanishes,
C  hence
C
      X = SRTINY * C1
      THRCOF(2) = X
      SUM1 = SUM1 + TINY * C1*C1
      IF(LSTEP.EQ.NFIN)   GO TO 220
      GO TO 30
C
C
   60 C2 = - OLDFAC / NEWFAC
C
C  Recursion to the next 3j coefficient
      X = C1 * THRCOF(LSTEP-1) + C2 * THRCOF(LSTEP-2)
      THRCOF(LSTEP) = X
      SUMFOR = SUM1
      SUM1 = SUM1 + X*X
      IF(LSTEP.EQ.NFIN)   GO TO 100
C
C  See if last unnormalized 3j coefficient exceeds SRHUGE
C
      IF(ABS(X).LT.SRHUGE)   GO TO 80
C
C  This is reached if last 3j coefficient larger than SRHUGE,
C  so that the recursion series THRCOF(1), ... , THRCOF(LSTEP)
C  has to be rescaled to prevent overflow
C
C     MSCALE = MSCALE + 1
      DO 70 I=1,LSTEP
      IF(ABS(THRCOF(I)).LT.SRTINY)   THRCOF(I) = ZERO
   70 THRCOF(I) = THRCOF(I) / SRHUGE
      SUM1 = SUM1 / HUGE
      SUMFOR = SUMFOR / HUGE
      X = X / SRHUGE
C
C
C  As long as ABS(C1) is decreasing, the recursion proceeds towards
C  increasing 3j values and, hence, is numerically stable.  Once
C  an increase of ABS(C1) is detected, the recursion direction is
C  reversed.
C
   80 IF(C1OLD-ABS(C1))   100, 100, 30
C
C
C  Keep three 3j coefficients around MMATCH for comparison later
C  with backward recursion values.
C
  100 CONTINUE
C     MMATCH = M2 - 1
      NSTEP2 = NFIN - LSTEP + 3
      X1 = X
      X2 = THRCOF(LSTEP-1)
      X3 = THRCOF(LSTEP-2)
C
C  Starting backward recursion from M2MAX taking NSTEP2 steps, so
C  that forwards and backwards recursion overlap at the three points
C  M2 = MMATCH+1, MMATCH, MMATCH-1.
C
      NFINP1 = NFIN + 1
      NFINP2 = NFIN + 2
      NFINP3 = NFIN + 3
      THRCOF(NFIN) = SRTINY
      SUM2 = TINY
C
C
C
      M2 = M2MAX + TWO
      LSTEP = 1
  110 LSTEP = LSTEP + 1
      M2 = M2 - ONE
      M3 = - M1 - M2
      OLDFAC = NEWFAC
      A1S = (L2-M2+TWO) * (L2+M2-ONE) * (L3+M3+TWO) * (L3-M3-ONE)
      NEWFAC = SQRT(A1S)
      DV = (L1+L2+L3+ONE)*(L2+L3-L1) - (L2-M2+ONE)*(L3+M3+ONE)
     1                               - (L2+M2-ONE)*(L3-M3-ONE)
      C1 = - DV / NEWFAC
      IF(LSTEP.GT.2)   GO TO 120
C
C  If M2 = M2MAX + 1 the third term in the recursion equation vanishes
C
      Y = SRTINY * C1
      THRCOF(NFIN-1) = Y
      IF(LSTEP.EQ.NSTEP2)   GO TO 200
      SUMBAC = SUM2
      SUM2 = SUM2 + Y*Y
      GO TO 110
C
  120 C2 = - OLDFAC / NEWFAC
C
C  Recursion to the next 3j coefficient
C
      Y = C1 * THRCOF(NFINP2-LSTEP) + C2 * THRCOF(NFINP3-LSTEP)
C
      IF(LSTEP.EQ.NSTEP2)   GO TO 200
C
      THRCOF(NFINP1-LSTEP) = Y
      SUMBAC = SUM2
      SUM2 = SUM2 + Y*Y
C
C
C  See if last 3j coefficient exceeds SRHUGE
C
      IF(ABS(Y).LT.SRHUGE)   GO TO 110
C
C  This is reached if last 3j coefficient larger than SRHUGE,
C  so that the recursion series THRCOF(NFIN), ... , THRCOF(NFIN-LSTEP+1)
C  has to be rescaled to prevent overflow.
C
C     MSCALE = MSCALE + 1
      DO 111 I=1,LSTEP
      INDEX = NFIN - I + 1
      IF(ABS(THRCOF(INDEX)).LT.SRTINY)
     1  THRCOF(INDEX) = ZERO
  111 THRCOF(INDEX) = THRCOF(INDEX) / SRHUGE
      SUM2 = SUM2 / HUGE
      SUMBAC = SUMBAC / HUGE
C
      GO TO 110
C
C
C
C  The forward recursion 3j coefficients X1, X2, X3 are to be matched
C  with the corresponding backward recursion values Y1, Y2, Y3.
C
  200 Y3 = Y
      Y2 = THRCOF(NFINP2-LSTEP)
      Y1 = THRCOF(NFINP3-LSTEP)
C
C
C  Determine now RATIO such that YI = RATIO * XI  (I=1,2,3) holds
C  with minimal error.
C
      RATIO = ( X1*Y1 + X2*Y2 + X3*Y3 ) / ( X1*X1 + X2*X2 + X3*X3 )
      NLIM = NFIN - NSTEP2 + 1
C
      IF(ABS(RATIO).LT.ONE)   GO TO 211
C
      DO 210 N=1,NLIM
  210 THRCOF(N) = RATIO * THRCOF(N)
      SUMUNI = RATIO * RATIO * SUMFOR + SUMBAC
      GO TO 230
C
  211 NLIM = NLIM + 1
      RATIO = ONE / RATIO
      DO 212 N=NLIM,NFIN
  212 THRCOF(N) = RATIO * THRCOF(N)
      SUMUNI = SUMFOR + RATIO*RATIO*SUMBAC
      GO TO 230
C
  220 SUMUNI = SUM1
C
C
C  Normalize 3j coefficients
C
  230 CNORM = ONE / SQRT((L1+L1+ONE) * SUMUNI)
C
C  Sign convention for last 3j coefficient determines overall phase
C
      SIGN1 = SIGN(ONE,THRCOF(NFIN))
      SIGN2 = (-ONE) ** INT(ABS(L2-L3-M1)+EPS)
      IF(SIGN1*SIGN2)  235,235,236
  235 CNORM = - CNORM
C
  236 IF(ABS(CNORM).LT.ONE)   GO TO 250
C
      DO 240 N=1,NFIN
  240 THRCOF(N) = CNORM * THRCOF(N)
      RETURN
C
  250 THRESH = TINY / ABS(CNORM)
      DO 251 N=1,NFIN
      IF(ABS(THRCOF(N)).LT.THRESH)   THRCOF(N) = ZERO
  251 THRCOF(N) = CNORM * THRCOF(N)
C
C
C
      RETURN
      END


C File: arrays-sect-19.f
C Illustrates array slicing

      program main
      implicit none

      integer, dimension (5,5) :: A
      integer :: i, j

      do i = 1, 5
          do j = 1, 5
              A(i,j) = 11*(i+j)
          end do
      end do

      do i = 1, 5
          write (*,10) A(i,1), A(i,2), A(i,3), A(i,4), A(i,5)
      end do
      write(*,11)

 10   format(5(I5,X))
 11   format('')

C      Modifying elements in a sub-array of A
       A( :, 3:5 ) = 999

      do i = 1, 5
          write (*,10) A(i,1), A(i,2), A(i,3), A(i,4), A(i,5)
      end do

      stop
      end program main