c======================================================================
       subroutine rpn2(ixy,maxm,meqn,mwaves,maux,mbc,mx,
     &                 ql,qr,auxl,auxr,fwave,s,amdq,apdq)
c======================================================================
c
c Solves normal Riemann problems for the 2D SHALLOW WATER equations
c     with topography:
c     #        h_t + (hu)_x + (hv)_y = 0                           #
c     #        (hu)_t + (hu^2 + 0.5gh^2)_x + (huv)_y = -ghb_x      #
c     #        (hv)_t + (huv)_x + (hv^2 + 0.5gh^2)_y = -ghb_y      #

c On input, ql contains the state vector at the left edge of each cell
c     qr contains the state vector at the right edge of each cell
c
c This data is along a slice in the x-direction if ixy=1
c     or the y-direction if ixy=2.

c  Note that the i'th Riemann problem has left state qr(i-1,:)
c     and right state ql(i,:)
c  From the basic clawpack routines, this routine is called with
c     ql = qr
c
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                           !
!      # This Riemann solver is for the shallow water adjoint               !
!             equations. It is modified from rpn2_geoclaw.f.                !
!                                                                           !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      use geoclaw_module, only: g => grav, drytol => dry_tolerance
      use geoclaw_module, only: earth_radius, deg2rad
      use amr_module, only: mcapa

      implicit none

      !input
      integer maxm,meqn,maux,mwaves,mbc,mx,ixy

      double precision  fwave(meqn, mwaves, 1-mbc:maxm+mbc)
      double precision  s(mwaves, 1-mbc:maxm+mbc)
      double precision  ql(meqn, 1-mbc:maxm+mbc)
      double precision  qr(meqn, 1-mbc:maxm+mbc)
      double precision  apdq(meqn,1-mbc:maxm+mbc)
      double precision  amdq(meqn,1-mbc:maxm+mbc)
      double precision  auxl(maux,1-mbc:maxm+mbc)
      double precision  auxr(maux,1-mbc:maxm+mbc)

      !local only
      integer m,i,mw,maxiter,mu,nv
      double precision wall(3)
      double precision fw(3,3)
      double precision sw(3)
      double precision delta(3)

      double precision hR,hL,huR,huL,uR,uL,hvR,hvL,vR,vL,phiR,phiL
      double precision bR,bL,cL,cR,sRoe1,sRoe2,sE1,sE2,uhat,chat
      double precision s1m,s2m
      double precision hstar,hstartest,hstarHLL,sLtest,sRtest
      double precision tw,dxdc
      double precision beta1, beta2, beta3, hRhat, hLhat

      logical rare1,rare2

      !loop through Riemann problems at each grid cell
      do i=2-mbc,mx+mbc

!-----------------------Initializing-----------------------------------
         !inform of a bad riemann problem from the start
         if((qr(1,i-1).lt.0.d0).or.(ql(1,i) .lt. 0.d0)) then
            write(*,*) 'Negative input: hl,hr,i=',qr(1,i-1),ql(1,i),i
         endif

        !Initialize Riemann problem for grid interface
        do mw=1,mwaves
            s(mw,i)=0.d0
            fwave(1,mw,i)=0.d0
            fwave(2,mw,i)=0.d0
            fwave(3,mw,i)=0.d0

            fw(1,mw)=0.d0
            fw(2,mw)=0.d0
            fw(3,mw)=0.d0
        enddo

         !set normal direction
         if (ixy.eq.1) then
            mu=2
            nv=3
         else
            mu=3
            nv=2
         endif

         !zero (small) negative values if they exist
         if (qr(1,i-1).lt.0.d0) then
           qr(1,i-1)=0.d0
           qr(2,i-1)=0.d0
           qr(3,i-1)=0.d0
         endif

        if (ql(1,i).lt.0.d0) then
          ql(1,i)=0.d0
          ql(2,i)=0.d0
          ql(3,i)=0.d0
        endif

         !skip problem if in a completely dry area
         if (qr(1,i-1) <= drytol .and. ql(1,i) <= drytol) then
             go to 30
         endif

        !Riemann problem variables
        hL = qr(1,i-1)
        hR = ql(1,i)
        bL = auxr(1,i-1)
        bR = auxl(1,i)

        huL = qr(mu,i-1)
        huR = ql(mu,i)
        hvL=qr(nv,i-1)
        hvR=ql(nv,i)

        ! Linearizing
        hLhat = -bL
        hRhat = -bR

c       ! Check for wet/dry boundary
        if (hR <= drytol) then
            hR = 0.d0
            huR = 0.d0
            hvR = 0.d0
            uR = 0.d0
            vR = 0.d0
            hRhat = 0.d0
        else
            uR = huR/hR
            vR = hvR/hR
        endif
        if (hL <= drytol) then
            hL = 0.d0
            huL = 0.d0
            hvL = 0.d0
            uL = 0.d0
            vL = 0.d0
            hLhat = 0.d0
        else
            uL = huL/hL
            vL = hvL/hL
        endif

        wall(1) = 1.d0
        wall(2) = 1.d0
        wall(3) = 1.d0

        if (hR.le.drytol) then
            call riemanntype(hL,hL,uL,-uL,hstar,s1m,s2m,
     &                                  rare1,rare2,1,drytol,g)
            hstartest=max(hL,hstar)
            if (hstartest+bL.lt.bR) then !right state should become ghost values
c                that mirror left for wall problem
                wall(2)=0.d0
                wall(3)=0.d0
                hR=hL
                huR=-huL
                bR=bL
                uR=-uL
                vR=vL
                hRhat = hLhat  ! added since this is a linear problem
             elseif (hL+bL.lt.bR) then
                bR=hL+bL
            endif
        elseif (hL.le.drytol) then ! right surface is lower than left topo
            call riemanntype(hR,hR,-uR,uR,hstar,s1m,s2m,
     &                                  rare1,rare2,1,drytol,g)
            hstartest=max(hR,hstar)
            if (hstartest+bR.lt.bL) then  !left state should become ghost values
c               that mirror right
                wall(1)=0.d0
                wall(2)=0.d0
                hL=hR
                huL=-huR
                bL=bR
                uL=-uR
                vL=vR
                hLhat = hRhat  ! added since this is a linear problem
            elseif (hR+bR.lt.bL) then
                bL=hR+bR
            endif
        endif

         !determine wave speeds
         cL=sqrt(g*hLhat) ! 1 wave speed of left state
         cR=sqrt(g*hRhat) ! 2 wave speed of right state

         !--------------------end initializing----------
         !solve Riemann problem.

c       # f-wave splitting
        delta(1) = -huR*cR**2 + huL*cL**2
        delta(2) = -(hR+bR) + (hL+bL)
        delta(3) = 0

        beta1 = (delta(1) + cR*delta(2))/(cL + cR)
        beta2 = (-delta(1) + cL*delta(2))/(cL + cR)
        beta3 = delta(3)

        if (cL + cR == 0.d0) then
            beta1 = (delta(1) + cR*delta(2))
            beta2 = (-delta(1) + cL*delta(2))
        endif

c       # Compute the waves.
        fw(1,1) = cL*beta1
        fw(mu,1) = beta1
        fw(nv,1) = 0.d0
        sw(1) = -cL

        fw(1,2) = -cR*beta2
        fw(mu,2) = beta2
        fw(nv,2) = 0.d0
        sw(2) = cR

c        !eliminate ghost fluxes for wall
         do mw=1,3
            sw(mw)=sw(mw)*wall(mw)

            fw(1,mw)=fw(1,mw)*wall(mw)
            fw(2,mw)=fw(2,mw)*wall(mw)
            fw(3,mw)=fw(3,mw)*wall(mw)
         enddo

         do mw=1,mwaves
            s(mw,i)=sw(mw)
            fwave(1,mw,i)=fw(1,mw)
            fwave(mu,mw,i)=fw(mu,mw)
            fwave(nv,mw,i)=fw(nv,mw)
         enddo

 30      continue
      enddo

c==========Capacity for mapping from latitude longitude to physical space====
        if (mcapa.gt.0) then
          do i=2-mbc,mx+mbc
            if (ixy.eq.1) then
              dxdc=(earth_radius*deg2rad)
            else
              dxdc=earth_radius*cos(auxl(3,i))*deg2rad
            endif

            do mw=1,mwaves
              s(mw,i)=dxdc*s(mw,i)
              fwave(1,mw,i)=dxdc*fwave(1,mw,i)
              fwave(2,mw,i)=dxdc*fwave(2,mw,i)
              fwave(3,mw,i)=dxdc*fwave(3,mw,i)
            enddo
          enddo
        endif

c============= compute fluctuations=============================================
         amdq(1:3,:) = 0.d0
         apdq(1:3,:) = 0.d0
         do i=2-mbc,mx+mbc
             do  mw=1,mwaves
               if (s(mw,i) < 0.d0) then
                 amdq(1:3,i) = amdq(1:3,i) + fwave(1:3,mw,i)
               else if (s(mw,i) > 0.d0) then
                 apdq(1:3,i)  = apdq(1:3,i) + fwave(1:3,mw,i)
               else
                 amdq(1:3,i) = amdq(1:3,i) + 0.5d0 * fwave(1:3,mw,i)
                 apdq(1:3,i) = apdq(1:3,i) + 0.5d0 * fwave(1:3,mw,i)
               endif
             enddo
         enddo

         do i=2-mbc, mx+mbc
             amdq(1:meqn,i) = fwave(1:meqn,1,i)
             apdq(1:meqn,i) = fwave(1:meqn,2,i)
         enddo

      return
      end subroutine


subroutine star_potential(md,xd,yd,zd,mg,xg,yg,zg,ms,xs,ys,zs,eps,nd,ng,ns,pots)
use omp_lib
implicit none

integer*4, intent(in) :: nd,ng,ns
real*8, intent(in), dimension(nd) :: md,xd,yd,zd
real*8, intent(in), dimension(ng) :: mg,xg,yg,zg
real*8, intent(in), dimension(ns) :: ms,xs,ys,zs
real*8, intent(in) :: eps
real*8, intent(out), dimension(ns) :: pots
integer*4 :: i,j
real*8 :: dist
integer :: num_threads

real*8, dimension(ns) :: ms2,xs2,ys2,zs2

do i=1,ns
  pots(i) = 0.0
  ms2(i) = ms(i)
  xs2(i) = xs(i)
  ys2(i) = ys(i)
  zs2(i) = zs(i)
enddo

!$omp parallel do private(i,j,dist) shared(pots,xs,ys,zs,ms,xd,yd,zd,md)
do i=1,ns
  do j=1,nd
    dist = sqrt( (xs(i)-xd(j))**2 + (ys(i)-yd(j))**2 + (zs(i)-zd(j))**2 + eps**2)
    pots(i) = pots(i)+md(j)/dist
  enddo
enddo
!$omp end parallel do

!$omp parallel do private(i,j,dist) shared(pots,xs,ys,zs,ms,xg,yg,zg,mg)
do i=1,ns
  do j=1,ng
    dist = sqrt( (xs(i)-xg(j))**2 + (ys(i)-yg(j))**2 + (zs(i)-zg(j))**2 + eps**2)
    pots(i) = pots(i)+mg(j)/dist
  enddo
enddo
!$omp end parallel do

!$omp parallel do private(i,j,dist) shared(pots,xs,ys,zs,ms,xs2,ys2,zs2,ms2)
do i=1,ns
  do j=1,ns
    dist = sqrt( (xs(i)-xs2(j))**2 + (ys(i)-ys2(j))**2 + (zs(i)-zs2(j))**2 + eps**2)
    pots(i) = pots(i)+ms2(j)/dist
  enddo
enddo
!$omp end parallel do

end subroutine star_potential

subroutine midplane_potential(md,xd,yd,zd,mg,xg,yg,zg,ms,xs,ys,zs,xin,yin,zin,eps,nd,ng,ns,ni,pote)
implicit none

integer*4, intent(in) :: nd,ng,ns,ni
real*8, intent(in), dimension(nd) :: md,xd,yd,zd
real*8, intent(in), dimension(ng) :: mg,xg,yg,zg
real*8, intent(in), dimension(ns) :: ms,xs,ys,zs
real*8, intent(in), dimension(ni) :: xin,yin,zin
real*8, intent(in) :: eps
real*8, intent(out), dimension(ni) :: pote
integer*4 :: i,j
real*8 :: dist

do i=1,ni
  pote(i) = 0.0
enddo

do i=1,ni
  do j=1,nd
    dist = sqrt( (xin(i)-xd(j))**2 + (yin(i)-yd(j))**2 + (zin(i)-zd(j))**2 + eps**2)
    pote(i) = pote(i)+md(j)/dist
  enddo
enddo

do i=1,ni
  do j=1,ng
    dist = sqrt( (xin(i)-xg(j))**2 + (yin(i)-yg(j))**2 + (zin(i)-zg(j))**2 + eps**2)
    pote(i) = pote(i)+mg(j)/dist
  enddo
enddo

do i=1,ni
  do j=1,ns
    dist = sqrt( (xin(i)-xs(j))**2 + (yin(i)-ys(j))**2 + (zin(i)-zs(j))**2 + eps**2)
    pote(i) = pote(i)+ms(j)/dist
  enddo
enddo

end subroutine midplane_potential

subroutine midplane_vcirc2(md,xd,yd,zd,mg,xg,yg,zg,ms,xs,ys,zs,xin,yin,zin,eps,nd,ng,ns,ni,vcirc2)
implicit none

integer*4, intent(in) :: nd,ng,ns,ni
real*8, intent(in), dimension(nd) :: md,xd,yd,zd
real*8, intent(in), dimension(ng) :: mg,xg,yg,zg
real*8, intent(in), dimension(ns) :: ms,xs,ys,zs
real*8, intent(in), dimension(ni) :: xin,yin,zin
real*8, intent(in) :: eps
real*8, intent(out), dimension(ni) :: vcirc2
integer*4 :: i,j
real*8 :: dist32
real*8, dimension(ni) :: acc_x, acc_y, acc_z

do i=1,ni
  acc_x(i) = 0.0
  acc_y(i) = 0.0
!   acc_z(i) = 0.0
enddo

do i=1,ni
  do j=1,nd
    dist32 = (sqrt( (xin(i)-xd(j))**2 + (yin(i)-yd(j))**2 + (zin(i)-zd(j))**2 + eps**2))**3
    acc_x(i) = acc_x(i)+md(j)/dist32*(xin(i)-xd(j))
    acc_y(i) = acc_y(i)+md(j)/dist32*(yin(i)-yd(j))
!     acc_z(i) = acc_z(i)+md(j)/dist32*(zin(i)-zd(j))
  enddo
enddo

do i=1,ni
  do j=1,ng
    dist32 = (sqrt( (xin(i)-xg(j))**2 + (yin(i)-yg(j))**2 + (zin(i)-zg(j))**2 + eps**2))**3
    acc_x(i) = acc_x(i)+mg(j)/dist32*(xin(i)-xg(j))
    acc_y(i) = acc_y(i)+mg(j)/dist32*(yin(i)-yg(j))
!     acc_z(i) = acc_z(i)+mg(j)/dist32*(zin(i)-zg(j))
  enddo
enddo

do i=1,ni
  do j=1,ns
    dist32 = (sqrt( (xin(i)-xs(j))**2 + (yin(i)-ys(j))**2 + (zin(i)-zs(j))**2 + eps**2))**3
    acc_x(i) = acc_x(i)+ms(j)/dist32*(xin(i)-xs(j))
    acc_y(i) = acc_y(i)+ms(j)/dist32*(yin(i)-ys(j))
!     acc_z(i) = acc_z(i)+ms(j)/dist32*(zin(i)-zs(j))
  enddo
enddo

do i=1,ni
  vcirc2(i) = acc_x(i)*xin(i) + acc_y(i)*yin(i)
enddo

end subroutine midplane_vcirc2


C  *********************************************************
C  *                                                       *
C  *    TEST NUMBER: 06.01.02/08                           *
C  *    TEST TITLE : Miscellaneous tests of modelling      *
C  *                 clipping                              *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      COMMON /GLOBNU/ CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT, DUMRL
      INTEGER         CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT(20), ERRIND
      REAL    DUMRL(20)

      COMMON /GLOBCH/ PIDENT,    GLBERR,    TSTMSG,     FUNCID,
     1                DUMCH
      CHARACTER       PIDENT*40, GLBERR*60, TSTMSG*900, FUNCID*80,
     1                DUMCH(20)*20

C modelling clipping operator
      INTEGER    PMCREP,     PMCINT
      PARAMETER (PMCREP = 1, PMCINT = 2)

C clipping indicator
C                noclip      clip
      INTEGER    PNCLIP,     PCLIP
      PARAMETER (PNCLIP = 0, PCLIP = 1)

C composition type
C                preconcatenate  postconcatenate  replace
      INTEGER    PCPRE,          PCPOST,          PCREPL
      PARAMETER (PCPRE = 0,      PCPOST = 1,      PCREPL = 2)

      INTEGER   HSSIZ, ASIZ,  IPL, NDPMCV, NOPL, NAVMCO, IDUM1

      REAL      A1(3,3), P1(3,3), P9(3,3), S2(3,3), R1(4,4), IDM(3,3)
      REAL      HS(6,1), A,B,C,D, PX,PY,PZ, INPTX(1),INPTY(1),INPTZ(1)
      REAL      OUTPTX(1),OUTPTY(1),OUTPTZ(1), UX,UY,UZ, HS2D(4,1)
      REAL      PI, U, NSDIST, XA(20),YA(20), ANGINC, RADIUS, ANG

      LOGICAL    SPHDIS

      PARAMETER (PI = 3.14159265)

      CHARACTER  EXPELM*5

      CALL INITGL ('06.01.02/08')
      CALL XPOPPH (ERRFIL, MEMUN)

      IF (.NOT. SPHDIS(123)) THEN
         CALL INMSG ('Skipping test because implementation '     //
     1               'apparently uses non-Euclidean metric for ' //
     2               'search distance.')
         GOTO 666
      ENDIF

C  Throughout, use incremental spatial search (ISS) to test the
C  effects of modelling clipping.

C  Set up structure #101
      CALL POPST (101)

C  In WC, polyline segment from (3,2) to (1,2) is clipped at 2,2 by
C  the MCV set up in element #2.

C  S2 = matrix for transformation to scale by 2 in x-direction
      CALL ESC (2.0, 1.0, S2)
      CALL PSGMT (S2)

C  2D half-space
      CALL SETRVS ('2,0, 2,1', HS2D, HSSIZ)
      CALL PSMCV (PMCREP, 1, HS2D)

C  P1 = matrix for transformation to shift by 1 in x-direction
      CALL ETR (1.0, 0.0, P1)
      CALL PSGMT (P1)

C  polyline coordinates
      CALL SETRVS ('2,0,2,0,2,0', XA, ASIZ)
      CALL SETRVS ('1,1,2,2,3,3', YA, ASIZ)
      CALL PPL (ASIZ, XA,YA)

C  R1 = matrix for random transformation
      DATA R1 / 0.7061, -0.2336,  0.2953, -0.2673,
     1         -0.2344,  0.8280, -0.2632, -0.2501,
     2          0.2709,  0.0524,  0.6326,  0.1435,
     3          0.3407,  0.3902,  0.1875,  1.2520 /
      CALL PSGMT3 (R1)

C  hsmcpt = half-space point in MC  = -1,0,1
C  hsmcvc = half-space vector in MC =  2,3,4
      CALL SETRVS ('-1,0,1,  2,3,4', HS, HSSIZ)
      CALL PSMCV3 (PMCREP, 1, HS)

C  P9 = matrix for transformation to shift by 9 in x-direction
      CALL ETR (9.0, 0.0, P9)
      CALL PSGMT (P9)

C  a,b,c,d = coefficients for WC boundary plane when R1 is applied
C  to the MC half-space defined by hsmcpt and hsmcvc.
      CALL TRANHS (HS, R1, A,B,C,D)

C  px,py,pz = the WC point where the line
C    x = a*u
C    y = b*u
C    z = 5
C  intersects the a*x + b*y + c*z + d = 0 plane
      U = ((-5*C) - D) / (A*A + B*B)
      PX = A*U
      PY = B*U
      PZ = 5.0

C  nsdist = nominal search distance
      NSDIST = 0.1

C  ux,uy,uz = unit vector parallel to a,b,c
      CALL VEC1 (A,B,C, UX,UY,UZ)

C  inpt = WC point inside volume
      INPTX(1) = PX + NSDIST * UX
      INPTY(1) = PY + NSDIST * UY
      INPTZ(1) = PZ + NSDIST * UZ

C  outpt = WC point outside volume
      OUTPTX(1) = PX - NSDIST * UX
      OUTPTY(1) = PY - NSDIST * UY
      OUTPTZ(1) = PZ - NSDIST * UZ

      CALL PPM3 (1, OUTPTX, OUTPTY, OUTPTZ)
      CALL PPM3 (1,  INPTX,  INPTY,  INPTZ)
      CALL PCLST

      CALL SETMSG ('15 17 18 40 42 43 49 57', 'When traversal '       //
     1             'causes different current modelling '              //
     2             'transformations to be applied in the generation ' //
     3             'of a polyline and a current MCV, the clipping '   //
     4             'should be performed relative to WC space.')

C  perform ISS with srp = (2-nsdist,2), clipping ON, starting at 101,0,
C    and sdist just below and above nsdist
C  pass/fail depending on (found path = first empty and then = 101,4)
      CALL ISSAB (2.0-NSDIST,2.0,0.0, NSDIST,
     1            '101,0', PCLIP, 1, '101,4')

      CALL SETMSG ('15 17 40 42 43 57', 'When traversal causes a '    //
     1             'perspective current modelling transformation to ' //
     2             'be applied in the generation of a current MCV, '  //
     3             'and a different current modelling '               //
     4             'transformation to be applied in the generation '  //
     5             'of a polymarker, the clipping should be '         //
     6             'performed relative to WC space.')

C  perform ISS with srp = outpt, clipping ON, starting at 101,0
C    and sdist just below and above 2*nsdist
C  pass/fail depending on (found path = first empty and then = 101,9)
      CALL ISSAB (OUTPTX(1),OUTPTY(1),OUTPTZ(1), 2*NSDIST,
     1            '101,0', PCLIP, 1, '101,9')

C  To test several boundary planes, set up a sequence of polymarkers
C  all on the unit circle, and arrange each clipping plane so as to
C  eliminate just one of them, by slicing off the edge of the
C  circle.  There will be only one polymarker left unclipped, and
C  this is the one to be found.
C
C  <inquire modelling clipping facilities> returns
C     ndpmcv = number of distinct planes for modelling clipping volume
      CALL PQMCLF (0, ERRIND, NDPMCV, NAVMCO, IDUM1)
      CALL CHKINQ ('pqmclf', ERRIND)

C  number of planes to be tested
      NOPL = MIN (50, NDPMCV)

C  angle increment
      ANGINC = (2*PI) / (NOPL + 1)

C  distance from origin of boundary planes
      RADIUS = (1 + COS(ANGINC)) / 2
      CALL SETRVS ('0,0,-1,0', HS2D, HSSIZ)
      HS2D (1,1) = RADIUS

C  A1  = matrix for transformation to rotate by anginc
      CALL ERO (ANGINC, A1)

C  idm = identity matrix
      CALL IDMAT (3, IDM)

C  Set up structure #102
      CALL POPST (102)
C  set up MCV to clip away all points except 1,0,0
      DO 210 IPL = 1,NOPL
         CALL PSLMT (A1, PCPRE)
         CALL PSMCV (PMCINT, 1, HS2D)
210   CONTINUE
      CALL PSLMT (IDM, PCREPL)

      DO 220 IPL = 1, NOPL+1
         ANG = ANGINC*IPL
         XA(1) = COS(ANG)
         YA(1) = SIN(ANG)
         CALL PPM (1, XA,YA)
220   CONTINUE

C  close structure #102
      CALL PCLST

      CALL SETMSG ('8 17 18 35 40 42 43 49 57', 'During traversal, ' //
     1             'it should be possible to construct the current ' //
     2             'MCV from as many half-spaces as are reported '   //
     3             'available by <inquire modelling clipping '       //
     4             'facilities>.')

C  expected element
      WRITE (EXPELM, '(I5)') 3*NOPL + 2

C  perform ISS with srp = 0,0, clipping ON, starting at 102,0
C    and sdist just below and above 1.0
C  pass/fail depending on (found path = first empty and then = 102,expelm)
      CALL ISSAB (0.0,0.0,0.0, 1.0, '102,0', PCLIP, 1,
     1            '102,' // EXPELM)

666   CONTINUE
      CALL ENDIT
      END


!-----------------------------------------------------------------------
!     Subroutine:    GENERIC_Evolve
!     Authors:       S. Lazerson (lazerson@pppl.gov)
!     Date:          03/13/2013
!     Description:   This subroutine preformes a particle swarm
!                    optimization of a target function (fcn).  The
!                    starting locations of the population are determined
!                    using a random number generator and are located
!                    between XCmin and XCmax.  One member of the
!                    population will start at the input value of x.
!-----------------------------------------------------------------------
      SUBROUTINE GENERIC_Evolve(fcn, m, n, NP, XCmin, XCmax, x, fvec, &
                           c1, c2, Vscale, ftol, xtol, maxfev, mode)
!-----------------------------------------------------------------------
!     Libraries
!-----------------------------------------------------------------------
      USE stel_kinds
      USE mpi_params
      USE safe_open_mod
      USE gade_mod, ONLY: pso_cleanup
      USE mpi_inc
      IMPLICIT NONE
!-----------------------------------------------------------------------
!     Input Variables
!        fcn     Target function one wishes to mimizie
!        m       Dimensionality of the function
!        n       Dimensionality of the function space
!        NP      Population size
!        XCmin   Minimum values of function space
!        XCmax   Maximum values of function space
!        x       Vector specifying mimium location in function space
!        fvec    Vector of function values at minimum
!        c1      Coefficient scaling local acceleration
!        c2      Coefficient scaling global acceleration
!        Vscale  Scaling factor for maximum velocity
!        ftol    Tollerance for global minimum in terms of fnorm
!        xtol    Tollerance for global minimum in terms of x
!        maxfev  Maximum number of function evaluations.
!----------------------------------------------------------------------
      INTEGER, INTENT(in) :: m, n, NP, maxfev, mode
      REAL(rprec), INTENT(in)  :: c1, c2, ftol, xtol, Vscale
      REAL(rprec), INTENT(in)  :: XCmin(n), XCmax(n)
      REAL(rprec), INTENT(inout) :: x(n)
      REAL(rprec), INTENT(out) :: fvec(m)
      EXTERNAL  fcn

!-----------------------------------------------------------------------
!     Local Variables
!        lkeep_running  Logical to control continued iteration
!        i,j            Dummy index
!        iproc_min      Index of processor with minimum fcn value
!        dex            Index of X-vector to use
!        generation     Current iteration of particle steps
!        iunit          File unit number
!        update_global  Flag to let que processors to update global min
!        nfeval         Counter for function evaluations
!        ierr           Error flag
!        istat          Status flag
!        exit_flag      Flag to control printing of exit message
!        fnorm          Function normalization SQRT(F.F)
!        fnorm_global   Global Min. function normalization
!        fnorm_personal Local Min. function normalization
!        fnorm_max      Maximum fnorm value encountered
!        x_max          Maximum distance across domain
!        gnorm          Distance to global min
!        pnorm          Distance to local min
!        vnorm          Velocity normalization
!        rand_C1        Random number
!        x_temp         Vector of input variables
!        fnorm_array    Vector of function values at (x_temp)
!        x_global       Vector of input variables (global min)
!        x_personal     Vector of input variables (local min)
!        vel            Velocity Vector
!        temp_fvec      Helper array
!        vmax           Array of maximum velocities
!        x_array        Array of all X's for the population
!----------------------------------------------------------------------
      LOGICAL :: lkeep_running, lfirst_pass, lnew_global
      INTEGER :: i,j, iproc_min, dex, generation, iunit, &
                 nfeval, ierr, istat, exit_flag, ntot
      REAL(rprec) :: fnorm, fnorm_global, anorm, &
                     vrand_C1, fnorm_max, xmax, l_temp
      REAL, PARAMETER :: dt = 0.1
      REAL(rprec), ALLOCATABLE :: x_temp(:), fnorm_array(:), &
                                  x_global(:), x_personal(:,:), &
                                  vel(:), fvec_temp(:), vmax(:), &
                                  fnorm_personal(:), accel(:), &
                                  h1a_array(:), h1b_array
      REAL(rprec), ALLOCATABLE :: x_array(:,:), fvec_array(:,:), vel_array(:,:), &
                                  h2a_array(:,:), h2b_array(:,:)
      CHARACTER(16) :: temp_string

      REAL(rprec) ::  enorm

!----------------------------------------------------------------------
!     BEGIN SUBROUTINE
!----------------------------------------------------------------------
      ! Preform Allocations
      ALLOCATE (x_temp(n), fnorm_array(NP), fnorm_personal(NP), &
                x_global(n),accel(n),vel(n), fvec_temp(m), &
                vmax(n), stat=ierr)
      ALLOCATE (x_array(n,NP),fvec_array(m,NP),x_personal(n,NP), &
                vel_array(n,NP),stat=ierr)

      ! Calculate VMAX
      xmax = enorm(n,XCmax-XCmin)
      vmax = Vscale*ABS((XCmax - XCmin))

      ! Initialize Starting Positions
      CALL RANDOM_SEED ( )  ! Processor reinitializes the seed
      IF (myid .eq. master) THEN
         x_array=0
         x_array(1,:) = x(:)
         DO i=2,NP
            DO j = 1, n
               CALL random_number(fnorm)
               x_array(j,i)=XCmin(j)+fnorm*(XCmax(j)-XCmin(j))
            END DO
         END DO
      END IF

!DEC$ IF DEFINED (MPI_OPT)
      CALL MPI_BARRIER(MPI_COMM_STEL, ierr)
      IF (ierr .ne. 0) CALL mpi_stel_abort(ierr)
      CALL MPI_BCAST(X_array,NP*n,MPI_REAL8,master,MPI_COMM_STEL,ierr)
      IF (ierr .ne. 0) CALL mpi_stel_abort(ierr)
!DEC$ ENDIF

      lkeep_running   = .true.
      lfirst_pass     = .true.
      x_global        = XCmax
      fnorm_global    = 1E30
      fnorm_personal  = 1E30
      iproc_min       = 1
      generation      = 1
      istat           = -1
      nfeval          = 0
      vel_array       = 0
      DO WHILE (lkeep_running)
         ! Evaluate population
         IF (lfirst_pass) THEN ! Execute first
            ! Have proc 0 evaluate
            IF (myid .eq. master) THEN
               x_temp        = x_array(1,:)
               fvec_temp(:)  = 0
               CALL fcn(m, n, x_temp, fvec_temp, istat, generation)
               fvec_array(:,1) = fvec_temp
               fnorm            = SQRT(SUM(fvec_temp*fvec_temp))
               WRITE(6,'(70("="))')
               WRITE(6,*) '   MEMBER      PROC          CHISQ'
               WRITE(6,'(70("="))')
               WRITE(6,'(2X,I6,8X,I3,7X,1ES12.4E2)') 1,0,fnorm**2
               CALL FLUSH(6)
            END IF
!DEC$ IF DEFINED (MPI_OPT)
            CALL MPI_BCAST(istat,1,MPI_INTEGER,0,MPI_COMM_STEL,ierr_mpi)
            CALL MPI_BARRIER(MPI_COMM_STEL, ierr_mpi)
!DEC$ ENDIF
            IF (istat < 0) THEN
               IF (myid == 0) WRITE(6,'(A)')'!!!!! First Eq failed !!!!!'
               DEALLOCATE(x_temp,fvec_temp)
               IF (ALLOCATED(x_array)) DEALLOCATE(x_array)
               IF (ALLOCATED(fvec_array)) DEALLOCATE(fvec_array)
               RETURN
            END IF

            ! Cleanup after first iteration
            istat = -100
            IF (myid .eq. 0) istat = -101
            i=0
            call fcn (m, n, x_temp, fvec_temp, istat, i)

            ntot = NP-1
            i=2; j=NP
         ELSE
            ntot = NP
            i=1; j=NP

            ! Write Generation Number to screeen
            IF (myid == master) THEN
               WRITE(6,'(A)') '   '
               WRITE(6,'(A,I5)')'---  Starting Generation',generation
            END IF
         END IF
         lfirst_pass = .false.

         ! Evaluate
         CALL eval_x_queued(fcn,m,n,ntot,x_array(1:n,i:j), &
                            fvec_array(1:m,i:j),nfeval,MPI_COMM_STEL)
         nfeval = nfeval + NP

!DEC$ IF DEFINED (MPI_OPT)
         CALL MPI_BCAST(fvec_array,NP*m,MPI_REAL8,master,MPI_COMM_STEL,ierr)
         IF (ierr .ne. 0) CALL mpi_stel_abort(ierr)
         CALL MPI_BCAST(x_array,NP*n,MPI_REAL8,master,MPI_COMM_STEL,ierr)
         IF (ierr .ne. 0) CALL mpi_stel_abort(ierr)
!DEC$ ENDIF

         ! Output the xvector and fevals
         IF (myid == master) THEN
            ! XVEC
            CALL safe_open(iunit,istat,'xvec.dat','unknown', &
                           'formatted', ACCESS_IN='APPEND')
            DO i = 1, NP
               WRITE(iunit,'(2(2X,I5.5))') n,generation
               fnorm = SQRT(SUM(fvec_array(:,i)*fvec_array(:,i),DIM=1))
               WRITE(iunit,'(10ES22.12E3)') x_array(1:n,i)
               WRITE(iunit,'(ES22.12E3)') fnorm
            END DO
            CLOSE(iunit)
            ! FEVALS
            WRITE(temp_string,'(i6.6)') generation
            iunit = 27; j=0;
            CALL safe_open(iunit,istat,'fevals.'//TRIM(temp_string), &
                           'new','formatted')
            WRITE(iunit,'(2X,i6,2X,i6)') m,n
            WRITE(iunit,'(1p,4e22.14)') (fvec(i), i=1,m)
            DO i = 1, m
               WRITE(iunit,'(1p,4e22.14)') (fvec_array(i,j), j=1,NP)
            END DO
            CLOSE(iunit)
         END IF

         ! Update values
         fnorm_array = SQRT(SUM(fvec_array*fvec_array,DIM=1))
         lnew_global = .false.
         iproc_min = -1
         DO  i=1, NP
            ! Local
            IF (fnorm_array(i) < fnorm_personal(i)) THEN
               fnorm_personal(i) = fnorm_array(i)
               x_personal(:,i) = x_array(:,i)
            END IF
            ! Global
            IF (fnorm_array(i) < fnorm_global) THEN
               ! Check for exit
               IF ((fnorm_global-fnorm_array(i))/fnorm_global < ftol) THEN
                  lkeep_running = .false.
                  exit_flag = 1
               END IF
               IF (MAXVAL(ABS((x_global-x_array(:,i))/x_global)) < xtol) THEN
                  lkeep_running = .false.
                  exit_flag = 2
               END IF
               ! Update values
               x_global = x_array(:,i)
               fnorm_global = fnorm_array(i)
               lnew_global = .true.
               iproc_min = i
            END IF
         END DO

         ! Print Minimum message
         IF (lnew_global) THEN
            x_temp = x_global
            IF (myid == master) THEN
               istat = myid+1
               CALL fcn(m, n, x_temp, fvec_temp, istat, generation)
               WRITE(6,'(A)') '   '
               WRITE(6,'(A,I5,A,1ES12.4E3)')'---  New global minimum at generation', &
                         generation,' Chi-Squared:',fnorm_global**2
               WRITE(6,'(A)') '   '
            END IF

            ! Cleanup after first iteration
            istat = -100
            IF (myid .eq. master) istat = pso_cleanup
            call fcn (m, n, x_temp, fvec_temp, istat, generation)
         END IF

         DO i = 1, NP
            ! Calculate Acceleration
            anorm = SQRT(SUM((x_global - x_array(:,i))**2))
            accel = (x_global - x_array(:,i))/(anorm*anorm*anorm)
            ! Calculate Velocity
            vel_array(:,i) = vel_array(:,i) + accel*dt

            ! Bound Velocity
            vel = vel_array(:,i)
            WHERE (ABS(vel)>vmax) vel = SIGN(vmax,vel)
            vel_array(:,i) = vel

            ! Step Particle
            x_array(:,i) = x_array(:,i) + vel*dt

            ! Kick minimum particle
            !IF (i==iproc_min) THEN
            !   DO j = 1, n
            !      CALL random_number(rand_C1)
            !      x_array(j,i)=XCmin(j)+rand_C1*(XCmax(j)-XCmin(j))
            !   END DO
            !   x_personal(:,iproc_min) = x_array(:,iproc_min)
            !   fnorm_personal(i) = 1E30
            !END IF

            ! Bound the particle
            x_temp = x_array(:,i)
            WHERE (x_temp > XCmax)
               x_temp = XCmax
               vel    = -vel*0.1
            END WHERE
            WHERE (x_temp < XCmin)
               x_temp = XCmin
               vel    = -vel*0.1
            END WHERE
            x_array(:,i) = x_temp
            vel_array(:,i) = vel
         END DO

         ! Test for max
         IF (generation == maxfev) THEN
            lkeep_running = .false.
            exit_flag = 3
         END IF

         ! Update Generation Number
         generation = generation + 1
      END DO

      ! PRINT Message
      IF (myid == master) THEN
         WRITE(6,*) ' '
         IF (exit_flag == 1) THEN
            WRITE(6,'(7X,A)') 'Execution Terminated FTOL Achieved'
         ELSE IF (exit_flag == 2) THEN
            WRITE(6,'(7X,A)') 'Execution Terminated XTOL Achieved'
         ELSE IF (exit_flag == 3) THEN
            WRITE(6,'(7X,A)') 'Execution Terminated MAXFEV Achieved'
         ELSE
            WRITE(6,'(7X,A)') 'Execution Terminated for unknown reason'
         END IF
         WRITE(6,*) ' '
      END IF
      x = x_global
      fvec = fvec_array(:,iproc_min)
      DEALLOCATE (x_temp,fnorm_array,fnorm_personal,x_global,vel,fvec_temp)
      DEALLOCATE (x_array, fvec_array, x_personal)

      RETURN
!----------------------------------------------------------------------
!     END SUBROUTINE
!----------------------------------------------------------------------
      END SUBROUTINE GENERIC_Evolve


      PROGRAM CTIMAA
*
*  -- LAPACK timing routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1999
*
*  Purpose
*  =======
*
*  CTIMAA is the timing program for the COMPLEX LAPACK
*  routines.  This program collects performance data for the factor,
*  solve, and inverse routines used in solving systems of linear
*  equations, and also for the orthogonal factorization and reduction
*  routines used in solving least squares problems and matrix eigenvalue
*  problems.
*
*  The subprograms call a REAL function SECOND with no
*  arguments which is assumed to return the central-processor time in
*  seconds from some fixed starting time.
*
*  The program is driven by a short data file, which specifies values
*  for the matrix dimensions M, N and K, for the blocking parameters
*  NB and NX, and for the leading array dimension LDA.  A minimum time
*  for each subroutine is included for timing small problems or for
*  obtaining results on a machine with an inaccurate SECOND function.
*
*  The matrix dimensions M, N, and K correspond to the three dimensions
*  m, n, and k in the Level 3 BLAS.  When timing the LAPACK routines for
*  square matrices, M and N correspond to the matrix dimensions m and n,
*  and K is the number of right-hand sides (nrhs) for the solves.  When
*  timing the LAPACK routines for band matrices, M is the matrix order
*  m, N is the half-bandwidth (kl, ku, or kd in the LAPACK notation),
*  and K is again the number of right-hand sides.
*
*  The first 13 records of the data file are read using list-directed
*  input.  The first line of input is printed as the first line of
*  output and can be used to identify different sets of results.  To
*  assist with debugging an input file, the values are printed out as
*  they are read in.
*
*  The following records are read using the format (A).  For these
*  records, the first 6 characters are reserved for the path or
*  subroutine name.  If a path name is used, the characters after the
*  path name indicate the routines in the path to be timed, where
*  'T' or 't' means 'Time this routine'.  If the line is blank after the
*  path name, all routines in the path are timed.  If fewer characters
*  appear than routines in a path, the remaining characters are assumed
*  to be 'F'.  For example, the following 3 lines are equivalent ways of
*  requesting timing of CGETRF:
*  CGE    T F F
*  CGE    T
*  CGETRF
*
*  An annotated example of a data file can be obtained by deleting the
*  first 3 characters from the following 32 lines:
*  LAPACK timing, COMPLEX square matrices
*  5                                Number of values of M
*  100 200 300 400 500              Values of M (row dimension)
*  5                                Number of values of N
*  100 200 300 400 500              Values of N (column dimension)
*  2                                Number of values of K
*  100 400                          Values of K
*  5                                Number of values of NB
*  1 16  32  48  64                 Values of NB (blocksize)
*  0 48 128 128 128                 Values of NX (crossover point)
*  2                                Number of values of LDA
*  512 513                          Values of LDA (leading dimension)
*  0.0                              Minimum time in seconds
*  CGE    T T T
*  CPO    T T T
*  CPP    T T T
*  CHE    T T T
*  CHP    T T T
*  CSY    T T T
*  CSP    T T T
*  CTR    T T
*  CTP    T T
*  CQR    T T F
*  CLQ    T T F
*  CQL    T T F
*  CRQ    T T F
*  CQP    T
*  CHR    T T F F
*  CTD    T T F F
*  CBR    T F F
*  CLS    T T T T T T
*
*  The routines are timed for all combinations of applicable values of
*  M, N, K, NB, NX, and LDA, and for all combinations of options such as
*  UPLO and TRANS.  For Level 2 BLAS timings, values of NB are used for
*  INCX.  Certain subroutines, such as the QR factorization, treat the
*  values of M and N as ordered pairs and operate on M x N matrices.
*
*  Internal Parameters
*  ===================
*
*  NMAX    INTEGER
*          The maximum value of M or N for square matrices.
*
*  LDAMAX  INTEGER
*          The maximum value of LDA.
*
*  NMAXB   INTEGER
*          The maximum value of N for band matrices.
*
*  MAXVAL  INTEGER
*          The maximum number of values that can be read in for M, N,
*          K, NB, or NX.
*
*  MXNLDA  INTEGER
*          The maximum number of values that can be read in for LDA.
*
*  NIN     INTEGER
*          The unit number for input.  Currently set to 5 (std input).
*
*  NOUT    INTEGER
*          The unit number for output.  Currently set to 6 (std output).
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            NMAX, LDAMAX, NMAXB
      PARAMETER          ( NMAX = 512, LDAMAX = NMAX+20, NMAXB = 5000 )
      INTEGER            LA
      PARAMETER          ( LA = NMAX*LDAMAX )
      INTEGER            MAXVAL, MXNLDA
      PARAMETER          ( MAXVAL = 12, MXNLDA = 4 )
      INTEGER            MAXPRM
      PARAMETER          ( MAXPRM = MXNLDA*(MAXVAL+1) )
      INTEGER            MAXSZS
      PARAMETER          ( MAXSZS = MAXVAL*MAXVAL*MAXVAL )
      INTEGER            NIN, NOUT
      PARAMETER          ( NIN = 5, NOUT = 6 )
*     ..
*     .. Local Scalars ..
      LOGICAL            BLAS, LDAMOK, LDANOK, LDAOK, MOK, NOK, NXNBOK
      CHARACTER          C1
      CHARACTER*2        C2
      CHARACTER*3        C3
      CHARACTER*80       LINE
      INTEGER            I, I2, J2, L, LDR1, LDR2, LDR3, MAXK, MAXLDA,
     $                   MAXM, MAXN, MAXNB, MKMAX, NEED, NK, NLDA, NM,
     $                   NN, NNB
      REAL               S1, S2, TIMMIN
*     ..
*     .. Local Arrays ..
      INTEGER            IWORK( 2*NMAXB ), KVAL( MAXVAL ),
     $                   LDAVAL( MXNLDA ), MVAL( MAXVAL ),
     $                   NBVAL( MAXVAL ), NVAL( MAXVAL ),
     $                   NXVAL( MAXVAL )
      REAL               D( 2*NMAX ),
     $                   FLPTBL( 6*6*MAXSZS*MAXPRM*5 ),
     $                   OPCTBL( 6*6*MAXSZS*MAXPRM*5 ),
     $                   RESLTS( MAXVAL, MAXVAL, 2*MXNLDA, 4*MAXVAL ),
     $                   RWORK( 150*NMAX+2*MAXVAL ), S( NMAX*2 ),
     $                   TIMTBL( 6*6*MAXSZS*MAXPRM*5 )
      COMPLEX            A( LA, 3 ), B( LA, 3 ), E( 2*NMAX ),
     $                   WORK( NMAX, NMAX+MAXVAL+10 )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME, LSAMEN
      REAL               SECOND
      EXTERNAL           LSAME, LSAMEN, SECOND
*     ..
*     .. External Subroutines ..
      EXTERNAL           CTIMB2, CTIMB3, CTIMBR, CTIMGB, CTIMGE, CTIMGT,
     $                   CTIMHE, CTIMHP, CTIMHR, CTIMLQ, CTIMLS, CTIMMM,
     $                   CTIMMV, CTIMPB, CTIMPO, CTIMPP, CTIMPT, CTIMQ3,
     $                   CTIMQL, CTIMQP, CTIMQR, CTIMRQ, CTIMSP, CTIMSY,
     $                   CTIMTB, CTIMTD, CTIMTP, CTIMTR
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Arrays in Common ..
      INTEGER            IPARMS( 100 )
*     ..
*     .. Common blocks ..
      COMMON             / CLAENV / IPARMS
*     ..
*     .. Executable Statements ..
*
      S1 = SECOND( )
      LDR1 = MAXVAL
      LDR2 = MAXVAL
      LDR3 = 2*MXNLDA
      WRITE( NOUT, FMT = 9983 )
*
*     Read the first line.  The first four characters must be 'BLAS'
*     for the BLAS data file format to be used.  Otherwise, the LAPACK
*     data file format is assumed.
*
      READ( NIN, FMT = '( A80 )' )LINE
      BLAS = LSAMEN( 4, LINE, 'BLAS' )
*
*     Find the last non-blank and print the first line of input as the
*     first line of output.
*
      DO 10 L = 80, 1, -1
         IF( LINE( L: L ).NE.' ' )
     $      GO TO 20
   10 CONTINUE
      L = 1
   20 CONTINUE
      WRITE( NOUT, FMT = '( 1X, A, / )' )LINE( 1: L )
      WRITE( NOUT, FMT = 9992 )
*
*     Read in NM and the values for M.
*
      READ( NIN, FMT = * )NM
      IF( NM.GT.MAXVAL ) THEN
         WRITE( NOUT, FMT = 9999 )'M', 'NM', MAXVAL
         NM = MAXVAL
      END IF
      READ( NIN, FMT = * )( MVAL( I ), I = 1, NM )
      WRITE( NOUT, FMT = 9991 )'M:     ', ( MVAL( I ), I = 1, NM )
*
*     Check that  M <= NMAXB for all values of M.
*
      MOK = .TRUE.
      MAXM = 0
      DO 30 I = 1, NM
         MAXM = MAX( MVAL( I ), MAXM )
         IF( MVAL( I ).GT.NMAXB ) THEN
            WRITE( NOUT, FMT = 9997 )'M', MVAL( I ), NMAXB
            MOK = .FALSE.
         END IF
   30 CONTINUE
      IF( .NOT.MOK )
     $   WRITE( NOUT, FMT = * )
*
*     Read in NN and the values for N.
*
      READ( NIN, FMT = * )NN
      IF( NN.GT.MAXVAL ) THEN
         WRITE( NOUT, FMT = 9999 )'N', 'NN', MAXVAL
         NN = MAXVAL
      END IF
      READ( NIN, FMT = * )( NVAL( I ), I = 1, NN )
      WRITE( NOUT, FMT = 9991 )'N:     ', ( NVAL( I ), I = 1, NN )
*
*     Check that  N <= NMAXB for all values of N.
*
      NOK = .TRUE.
      MAXN = 0
      DO 40 I = 1, NN
         MAXN = MAX( NVAL( I ), MAXN )
         IF( NVAL( I ).GT.NMAXB ) THEN
            WRITE( NOUT, FMT = 9997 )'N', NVAL( I ), NMAXB
            NOK = .FALSE.
         END IF
   40 CONTINUE
      IF( .NOT.NOK )
     $   WRITE( NOUT, FMT = * )
*
*     Read in NK and the values for K.
*
      READ( NIN, FMT = * )NK
      IF( NK.GT.MAXVAL ) THEN
         WRITE( NOUT, FMT = 9999 )'K', 'NK', MAXVAL
         NK = MAXVAL
      END IF
      READ( NIN, FMT = * )( KVAL( I ), I = 1, NK )
      WRITE( NOUT, FMT = 9991 )'K:     ', ( KVAL( I ), I = 1, NK )
*
*     Find the maximum value of K (= NRHS).
*
      MAXK = 0
      DO 50 I = 1, NK
         MAXK = MAX( KVAL( I ), MAXK )
   50 CONTINUE
      MKMAX = MAXM*MAX( 2, MAXK )
*
*     Read in NNB and the values for NB.  For the BLAS input files,
*     NBVAL is used to store values for INCX and INCY.
*
      READ( NIN, FMT = * )NNB
      IF( NNB.GT.MAXVAL ) THEN
         WRITE( NOUT, FMT = 9999 )'NB', 'NNB', MAXVAL
         NNB = MAXVAL
      END IF
      READ( NIN, FMT = * )( NBVAL( I ), I = 1, NNB )
*
*     Find the maximum value of NB.
*
      MAXNB = 0
      DO 60 I = 1, NNB
         MAXNB = MAX( NBVAL( I ), MAXNB )
   60 CONTINUE
*
      IF( BLAS ) THEN
         WRITE( NOUT, FMT = 9991 )'INCX:  ', ( NBVAL( I ), I = 1, NNB )
         DO 70 I = 1, NNB
            NXVAL( I ) = 0
   70    CONTINUE
      ELSE
*
*        LAPACK data files:  Read in the values for NX.
*
         READ( NIN, FMT = * )( NXVAL( I ), I = 1, NNB )
*
         WRITE( NOUT, FMT = 9991 )'NB:    ', ( NBVAL( I ), I = 1, NNB )
         WRITE( NOUT, FMT = 9991 )'NX:    ', ( NXVAL( I ), I = 1, NNB )
      END IF
*
*     Read in NLDA and the values for LDA.
*
      READ( NIN, FMT = * )NLDA
      IF( NLDA.GT.MXNLDA ) THEN
         WRITE( NOUT, FMT = 9999 )'LDA', 'NLDA', MXNLDA
         NLDA = MXNLDA
      END IF
      READ( NIN, FMT = * )( LDAVAL( I ), I = 1, NLDA )
      WRITE( NOUT, FMT = 9991 )'LDA:   ', ( LDAVAL( I ), I = 1, NLDA )
*
*     Check that LDA >= 1 for all values of LDA.
*
      LDAOK = .TRUE.
      MAXLDA = 0
      DO 80 I = 1, NLDA
         MAXLDA = MAX( LDAVAL( I ), MAXLDA )
         IF( LDAVAL( I ).LE.0 ) THEN
            WRITE( NOUT, FMT = 9998 )LDAVAL( I )
            LDAOK = .FALSE.
         END IF
   80 CONTINUE
      IF( .NOT.LDAOK )
     $   WRITE( NOUT, FMT = * )
*
*     Check that MAXLDA*MAXN <= LA (for the dense routines).
*
      LDANOK = .TRUE.
      NEED = MAXLDA*MAXN
      IF( NEED.GT.LA ) THEN
         WRITE( NOUT, FMT = 9995 )MAXLDA, MAXN, NEED
         LDANOK = .FALSE.
      END IF
*
*     Check that MAXLDA*MAXM + MAXM*MAXK <= 3*LA (for band routines).
*
      LDAMOK = .TRUE.
      NEED = MAXLDA*MAXM + MAXM*MAXK
      IF( NEED.GT.3*LA ) THEN
         NEED = ( NEED+2 ) / 3
         WRITE( NOUT, FMT = 9994 )MAXLDA, MAXM, MAXK, NEED
         LDAMOK = .FALSE.
      END IF
*
*     Check that MAXN*MAXNB (or MAXN*INCX) <= LA.
*
      NXNBOK = .TRUE.
      NEED = MAXN*MAXNB
      IF( NEED.GT.LA ) THEN
         WRITE( NOUT, FMT = 9996 )MAXN, MAXNB, NEED
         NXNBOK = .FALSE.
      END IF
*
      IF( .NOT.( MOK .AND. NOK .AND. LDAOK .AND. LDANOK .AND. NXNBOK ) )
     $     THEN
         WRITE( NOUT, FMT = 9984 )
         GO TO 110
      END IF
      IF( .NOT.LDAMOK )
     $   WRITE( NOUT, FMT = * )
*
*     Read the minimum time to time a subroutine.
*
      WRITE( NOUT, FMT = * )
      READ( NIN, FMT = * )TIMMIN
      WRITE( NOUT, FMT = 9993 )TIMMIN
      WRITE( NOUT, FMT = * )
*
*     Read the first input line.
*
      READ( NIN, FMT = '(A)', END = 100 )LINE
*
*     If the first record is the special signal 'NONE', then get the
*     next line but don't time CGEMV and CGEMM.
*
      IF( LSAMEN( 4, LINE, 'NONE' ) ) THEN
         READ( NIN, FMT = '(A)', END = 100 )LINE
      ELSE
         WRITE( NOUT, FMT = 9990 )
*
*        If the first record is the special signal 'BAND', then time
*        the band routine CGBMV and CGEMM with N = K.
*
         IF( LSAMEN( 4, LINE, 'BAND' ) ) THEN
            IF( LDAMOK ) THEN
               IF( MKMAX.GT.LA ) THEN
                  I2 = 2*LA - MKMAX + 1
                  J2 = 2
               ELSE
                  I2 = LA - MKMAX + 1
                  J2 = 3
               END IF
               CALL CTIMMV( 'CGBMV ', NM, MVAL, NN, NVAL, NLDA, LDAVAL,
     $                      TIMMIN, A( 1, 1 ), MKMAX / 2, A( I2, J2 ),
     $                      A( LA-MKMAX / 2+1, 3 ), RESLTS, LDR1, LDR2,
     $                      NOUT )
            ELSE
               WRITE( NOUT, FMT = 9989 )'CGBMV '
            END IF
            CALL CTIMMM( 'CGEMM ', 'K', NN, NVAL, NLDA, LDAVAL, TIMMIN,
     $                   A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), RESLTS, LDR1,
     $                   LDR2, NOUT )
            READ( NIN, FMT = '(A)', END = 100 )LINE
*
         ELSE
*
*           Otherwise time CGEMV and CGEMM.
*
            CALL CTIMMV( 'CGEMV ', NN, NVAL, NNB, NBVAL, NLDA, LDAVAL,
     $                   TIMMIN, A( 1, 1 ), LA, A( 1, 2 ), A( 1, 3 ),
     $                   RESLTS, LDR1, LDR2, NOUT )
            CALL CTIMMM( 'CGEMM ', 'N', NN, NVAL, NLDA, LDAVAL, TIMMIN,
     $                   A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), RESLTS, LDR1,
     $                   LDR2, NOUT )
         END IF
      END IF
*
*     Call the appropriate timing routine for each input line.
*
      WRITE( NOUT, FMT = 9988 )
   90 CONTINUE
      C1 = LINE( 1: 1 )
      C2 = LINE( 2: 3 )
      C3 = LINE( 4: 6 )
*
*     Check first character for correct precision.
*
      IF( .NOT.LSAME( C1, 'Complex precision' ) ) THEN
         WRITE( NOUT, FMT = 9987 )LINE( 1: 6 )
*
      ELSE IF( LSAMEN( 2, C2, 'B2' ) .OR. LSAMEN( 3, C3, 'MV ' ) .OR.
     $         LSAMEN( 3, C3, 'SV ' ) .OR. LSAMEN( 3, C3, 'R  ' ) .OR.
     $         LSAMEN( 3, C3, 'RC ' ) .OR. LSAMEN( 3, C3, 'RU ' ) .OR.
     $         LSAMEN( 3, C3, 'R2 ' ) ) THEN
*
*        Level 2 BLAS
*
         CALL CTIMB2( LINE, NM, MVAL, NN, NVAL, NK, KVAL, NNB, NBVAL,
     $                NLDA, LDAVAL, LA, TIMMIN, A( 1, 1 ), A( 1, 2 ),
     $                A( 1, 3 ), RESLTS, LDR1, LDR2, NOUT )
*
      ELSE IF( LSAMEN( 2, C2, 'B3' ) .OR. LSAMEN( 3, C3, 'MM ' ) .OR.
     $         LSAMEN( 3, C3, 'SM ' ) .OR. LSAMEN( 3, C3, 'RK ' ) .OR.
     $         LSAMEN( 3, C3, 'R2K' ) ) THEN
*
*        Level 3 BLAS
*
         CALL CTIMB3( LINE, NM, MVAL, NN, NVAL, NK, KVAL, NLDA, LDAVAL,
     $                TIMMIN, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), RESLTS,
     $                LDR1, LDR2, NOUT )
*
      ELSE IF( LSAMEN( 2, C2, 'QR' ) .OR. LSAMEN( 2, C3, 'QR' ) .OR.
     $         LSAMEN( 2, C3( 2: 3 ), 'QR' ) ) THEN
*
*        QR routines
*
         CALL CTIMQR( LINE, NN, MVAL, NVAL, NK, KVAL, NNB, NBVAL, NXVAL,
     $                NLDA, LDAVAL, TIMMIN, A( 1, 1 ), E, A( 1, 2 ),
     $                A( 1, 3 ), D, RESLTS, LDR1, LDR2, LDR3, NOUT )
*
      ELSE IF( LSAMEN( 2, C2, 'LQ' ) .OR. LSAMEN( 2, C3, 'LQ' ) .OR.
     $         LSAMEN( 2, C3( 2: 3 ), 'LQ' ) ) THEN
*
*        LQ routines
*
         CALL CTIMLQ( LINE, NN, MVAL, NVAL, NK, KVAL, NNB, NBVAL, NXVAL,
     $                NLDA, LDAVAL, TIMMIN, A( 1, 1 ), E, A( 1, 2 ),
     $                A( 1, 3 ), D, RESLTS, LDR1, LDR2, LDR3, NOUT )
*
      ELSE IF( LSAMEN( 2, C2, 'QL' ) .OR. LSAMEN( 2, C3, 'QL' ) .OR.
     $         LSAMEN( 2, C3( 2: 3 ), 'QL' ) ) THEN
*
*        QL routines
*
         CALL CTIMQL( LINE, NN, MVAL, NVAL, NK, KVAL, NNB, NBVAL, NXVAL,
     $                NLDA, LDAVAL, TIMMIN, A( 1, 1 ), E, A( 1, 2 ),
     $                A( 1, 3 ), D, RESLTS, LDR1, LDR2, LDR3, NOUT )
*
      ELSE IF( LSAMEN( 2, C2, 'RQ' ) .OR. LSAMEN( 2, C3, 'RQ' ) .OR.
     $         LSAMEN( 2, C3( 2: 3 ), 'RQ' ) ) THEN
*
*        RQ routines
*
         CALL CTIMRQ( LINE, NN, MVAL, NVAL, NK, KVAL, NNB, NBVAL, NXVAL,
     $                NLDA, LDAVAL, TIMMIN, A( 1, 1 ), E, A( 1, 2 ),
     $                A( 1, 3 ), D, RESLTS, LDR1, LDR2, LDR3, NOUT )
*
      ELSE IF( LSAMEN( 2, C2, 'QP' ) .OR. LSAMEN( 3, C3, 'QPF' ) ) THEN
*
*        QR with column pivoting
*
         CALL CTIMQP( LINE, NM, MVAL, NVAL, NLDA, LDAVAL, TIMMIN,
     $                A( 1, 1 ), A( 1, 2 ), E, A( 1, 3 ), D, IWORK,
     $                RESLTS, LDR1, LDR2, NOUT )
*
*        Rank-Revealing QR factorization
*
         CALL CTIMQ3( LINE, NM, MVAL, NVAL, NNB, NBVAL, NXVAL, NLDA,
     $                LDAVAL, TIMMIN, A( 1, 1 ), A( 1, 2 ), E,
     $                A( 1, 3 ), D, IWORK, RESLTS, LDR1, LDR2, NOUT )
*
      ELSE IF( LSAMEN( 2, C2, 'HR' ) .OR. LSAMEN( 3, C3, 'HRD' ) .OR.
     $         LSAMEN( 2, C3( 2: 3 ), 'HR' ) ) THEN
*
*        Reduction to Hessenberg form
*
         CALL CTIMHR( LINE, NN, NVAL, NK, KVAL, NNB, NBVAL, NXVAL, NLDA,
     $                LDAVAL, TIMMIN, A( 1, 1 ), E, A( 1, 2 ),
     $                A( 1, 3 ), D, RESLTS, LDR1, LDR2, LDR3, NOUT )
*
      ELSE IF( LSAMEN( 2, C2, 'TD' ) .OR. LSAMEN( 3, C3, 'TRD' ) .OR.
     $         LSAMEN( 2, C3( 2: 3 ), 'TR' ) ) THEN
*
*        Reduction to tridiagonal form
*
         CALL CTIMTD( LINE, NN, NVAL, NK, KVAL, NNB, NBVAL, NXVAL, NLDA,
     $                LDAVAL, TIMMIN, A( 1, 1 ), A( 1, 2 ), D, E,
     $                A( 1, 3 ), RESLTS, LDR1, LDR2, LDR3, NOUT )
*
      ELSE IF( LSAMEN( 2, C2, 'BR' ) .OR. LSAMEN( 3, C3, 'BRD' ) .OR.
     $         LSAMEN( 2, C3( 2: 3 ), 'BR' ) ) THEN
*
*        Reduction to bidiagonal form
*
         CALL CTIMBR( LINE, NN, MVAL, NVAL, NK, KVAL, NNB, NBVAL, NXVAL,
     $                NLDA, LDAVAL, TIMMIN, A( 1, 1 ), A( 1, 2 ), D, E,
     $                A( 1, 3 ), RESLTS, LDR1, LDR2, LDR3, NOUT )
*
      ELSE IF( LSAMEN( 2, C2, 'GE' ) ) THEN
*
*        Routines for general matrices
*
         CALL CTIMGE( LINE, NN, NVAL, NK, KVAL, NNB, NBVAL, NLDA,
     $                LDAVAL, TIMMIN, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
     $                IWORK, RESLTS, LDR1, LDR2, LDR3, NOUT )
*
      ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN
*
*        General band matrices
*
         IF( LDAMOK ) THEN
            CALL CTIMGB( LINE, NM, MVAL, NN, NVAL, NK, KVAL, NNB, NBVAL,
     $                   NLDA, LDAVAL, TIMMIN, A( 1, 1 ),
     $                   A( LA-MKMAX+1, 3 ), IWORK, RESLTS, LDR1, LDR2,
     $                   LDR3, NOUT )
         ELSE
            WRITE( NOUT, FMT = 9989 )LINE( 1: 6 )
         END IF
*
      ELSE IF( LSAMEN( 2, C2, 'GT' ) ) THEN
*
*        Routines for general tridiagonal matrices
*
         CALL CTIMGT( LINE, NN, NVAL, NK, KVAL, NLDA, LDAVAL, TIMMIN,
     $                A( 1, 1 ), A( 1, 2 ), IWORK, RESLTS, LDR1, LDR2,
     $                LDR3, NOUT )
*
      ELSE IF( LSAMEN( 2, C2, 'PO' ) ) THEN
*
*        Positive definite matrices
*
         CALL CTIMPO( LINE, NN, NVAL, NK, KVAL, NNB, NBVAL, NLDA,
     $                LDAVAL, TIMMIN, A( 1, 1 ), A( 1, 2 ), IWORK,
     $                RESLTS, LDR1, LDR2, LDR3, NOUT )
*
      ELSE IF( LSAMEN( 2, C2, 'PP' ) ) THEN
*
*        Positive definite packed matrices
*
         CALL CTIMPP( LINE, NN, NVAL, NK, KVAL, LA, TIMMIN, A( 1, 1 ),
     $                A( 1, 2 ), IWORK, RESLTS, LDR1, LDR2, LDR3, NOUT )
*
      ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN
*
*        Positive definite banded matrices
*
         IF( LDAMOK ) THEN
            IF( MKMAX.GT.LA ) THEN
               J2 = 2
               I2 = 2*LA - MKMAX + 1
            ELSE
               J2 = 3
               I2 = LA - MKMAX + 1
            END IF
            CALL CTIMPB( LINE, NM, MVAL, NN, NVAL, NK, KVAL, NNB, NBVAL,
     $                   NLDA, LDAVAL, TIMMIN, A( 1, 1 ), A( I2, J2 ),
     $                   IWORK, RESLTS, LDR1, LDR2, LDR3, NOUT )
         ELSE
            WRITE( NOUT, FMT = 9989 )LINE( 1: 6 )
         END IF
*
      ELSE IF( LSAMEN( 2, C2, 'PT' ) ) THEN
*
*        Routines for positive definite tridiagonal matrices
*
         CALL CTIMPT( LINE, NN, NVAL, NK, KVAL, NLDA, LDAVAL, TIMMIN, D,
     $                A( 1, 1 ), A( 1, 2 ), RESLTS, LDR1, LDR2, LDR3,
     $                NOUT )
*
      ELSE IF( LSAMEN( 2, C2, 'HE' ) ) THEN
*
*        Hermitian indefinite matrices
*
         CALL CTIMHE( LINE, NN, NVAL, NK, KVAL, NNB, NBVAL, NLDA,
     $                LDAVAL, TIMMIN, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
     $                IWORK, RESLTS, LDR1, LDR2, LDR3, NOUT )
*
      ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN
*
*        Hermitian indefinite packed matrices
*
         CALL CTIMHP( LINE, NN, NVAL, NK, KVAL, LA, TIMMIN, A( 1, 1 ),
     $                A( 1, 2 ), A( 1, 3 ), IWORK, RESLTS, LDR1, LDR2,
     $                LDR3, NOUT )
*
      ELSE IF( LSAMEN( 2, C2, 'SY' ) ) THEN
*
*        Symmetric indefinite matrices
*
         CALL CTIMSY( LINE, NN, NVAL, NK, KVAL, NNB, NBVAL, NLDA,
     $                LDAVAL, TIMMIN, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
     $                IWORK, RESLTS, LDR1, LDR2, LDR3, NOUT )
*
      ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
*        Symmetric indefinite packed matrices
*
         CALL CTIMSP( LINE, NN, NVAL, NK, KVAL, LA, TIMMIN, A( 1, 1 ),
     $                A( 1, 2 ), A( 1, 3 ), IWORK, RESLTS, LDR1, LDR2,
     $                LDR3, NOUT )
*
      ELSE IF( LSAMEN( 2, C2, 'TR' ) ) THEN
*
*        Triangular matrices
*
         CALL CTIMTR( LINE, NN, NVAL, NK, KVAL, NNB, NBVAL, NLDA,
     $                LDAVAL, TIMMIN, A( 1, 1 ), A( 1, 2 ), RESLTS,
     $                LDR1, LDR2, LDR3, NOUT )
*
      ELSE IF( LSAMEN( 2, C2, 'TP' ) ) THEN
*
*        Triangular packed matrices
*
         CALL CTIMTP( LINE, NN, NVAL, NK, KVAL, LA, TIMMIN, A( 1, 1 ),
     $                A( 1, 2 ), RESLTS, LDR1, LDR2, LDR3, NOUT )
*
      ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
*
*        Triangular band matrices
*
         IF( LDAMOK ) THEN
            IF( MKMAX.GT.LA ) THEN
               J2 = 2
               I2 = 2*LA - MKMAX + 1
            ELSE
               J2 = 3
               I2 = LA - MKMAX + 1
            END IF
            CALL CTIMTB( LINE, NM, MVAL, NN, NVAL, NK, KVAL, NLDA,
     $                   LDAVAL, TIMMIN, A( 1, 1 ), A( I2, J2 ), RESLTS,
     $                   LDR1, LDR2, LDR3, NOUT )
         ELSE
            WRITE( NOUT, FMT = 9989 )LINE( 1: 6 )
         END IF
*
      ELSE IF( LSAMEN( 2, C2, 'LS' ) ) THEN
*
*        Least squares drivers
*
         CALL CTIMLS( LINE, NM, MVAL, NN, NVAL, NK, KVAL, NNB, NBVAL,
     $                NXVAL, NLDA, LDAVAL, TIMMIN, A( 1, 1 ), A( 1, 2 ),
     $                B( 1, 1 ), B( 1, 2 ), S, S( NMAX+1 ), OPCTBL,
     $                TIMTBL, FLPTBL, WORK, RWORK, IWORK, NOUT )
*
      ELSE
*
         WRITE( NOUT, FMT = 9987 )LINE( 1: 6 )
      END IF
*
*     Read the next line of the input file.
*
      READ( NIN, FMT = '(A)', END = 100 )LINE
      GO TO 90
*
*     Branch to this line when the last record is read.
*
  100 CONTINUE
      S2 = SECOND( )
      WRITE( NOUT, FMT = 9986 )
      WRITE( NOUT, FMT = 9985 )S2 - S1
  110 CONTINUE
*
 9999 FORMAT( ' Too many values of ', A, ' using ', A, ' = ', I2 )
 9998 FORMAT( ' *** LDA = ', I7, ' is too small, must have ',
     $      'LDA > 0.' )
 9997 FORMAT( ' *** ', A1, ' = ', I7, ' is too big:  ',
     $      'maximum allowed is', I7 )
 9996 FORMAT( ' *** N*NB is too big for N =', I6, ', NB =', I6,
     $      / ' --> Increase LA to at least ', I8 )
 9995 FORMAT( ' *** LDA*N is too big for the dense routines ', '(LDA =',
     $      I6, ', N =', I6, ')', / ' --> Increase LA to at least ',
     $      I8 )
 9994 FORMAT( ' *** (LDA+K)*M is too big for the band routines ',
     $      '(LDA=', I6, ', M=', I6, ', K=', I6, ')',
     $      / ' --> Increase LA to at least ', I8 )
 9993 FORMAT( ' The minimum time a subroutine will be timed = ', F6.3,
     $      ' seconds' )
 9992 FORMAT( ' The following parameter values will be used:' )
 9991 FORMAT( 4X, A7, 1X, 10I6, / 12X, 10I6 )
 9990 FORMAT( / ' ------------------------------',
     $      / ' >>>>>    Sample BLAS     <<<<<',
     $      / ' ------------------------------' )
 9989 FORMAT( 1X, A6, ' not timed due to input errors', / )
 9988 FORMAT( / ' ------------------------------',
     $      / ' >>>>>    Timing data     <<<<<',
     $      / ' ------------------------------' )
 9987 FORMAT( 1X, A6, ':  Unrecognized path or subroutine name', / )
 9986 FORMAT( ' End of tests' )
 9985 FORMAT( ' Total time used = ', F12.2, ' seconds' )
 9984 FORMAT( / ' Tests not done due to input errors' )
 9983 FORMAT( ' LAPACK VERSION 3.0, released June 30, 1999 ', / )
*
*     End of CTIMAA
*
      END


      program DRSPSI
c>> 1996-06-19 DRSPSI Krogh  Minor change in format for C conversion.
c>> 1994-10-19 DRSPSI Krogh  Changes to use M77CON
c>> 1994-09-01 DRSPSI CLL
c>> 1994-07-21 DRSPSI WVS Original Code
c--S replaces "?": DR?PSI, ?PSI, ?PSIE
      real             E, P, SPSI, X
      integer I, IE
      external SPSI
      print '(''          X        SPSI(X)     FLAG  EST.ABS.ERR'')'
      x = -4.5e0
      do 10 i = 1, 14
         p = spsi(x)
         call spsie (e, ie)
         print '(2x,2g14.8,i4,2x,g14.8)', x, p, ie, e*abs(p)
         x = x + 1.0e0
   10 continue
      stop
      end


module class_Square

  implicit none
  private

  type, public :: Square
    real :: side
  contains
    procedure :: area => square_area
    procedure :: print => square_print
  end type

contains

  pure function square_area(this) result(area)

    class(Square), intent(in) :: this
    real :: area

    area = this%side**2

  end function

  subroutine square_print(this)

    class(Square), intent(in) :: this
    real:: area

    area = this%area()
    print *, 'Square: l = ', this%side, ' area = ', area

  end subroutine

end module


      double complex function Fcc_qpgpgpqm(j1,j2,j3,j4,j5,j6,za,zb)
      implicit none
      integer j1,j2,j3,j4,j5,j6
      include 'constants.f'
      include 'zprods_decl.f'
      include 'sprods_com.f'
      double complex L0,Lsm1,Lsm1_2me
      double precision t

      Fcc_qpgpgpqm=
     .-(((-Lsm1(-s(j1,j2),-t(j1,j2,j3),-s(j2,j3),-t(j1,j2,j3))-
     .Lsm1(-s(j2,j3),-t(j2,j3,j4),-s(j3,j4),-t(j2,j3,j4))-
     .Lsm1_2me(t(j1,j2,j3),t(j2,j3,j4),s(j2,j3),s(j5,j6)))*za(j4,j5)**2)
     ./
     .(za(j1,j2)*za(j2,j3)*za(j3,j4)*za(j5,j6)))-
     .(2d0*L0(-t(j2,j3,j4),-s(j3,j4))*za(j2,j5)*za(j4,j5)*zb(j2,j3))/
     .(s(j3,j4)*za(j1,j2)*za(j2,j3)*za(j5,j6))-
     .(2d0*L0(-s(j5,j6),-t(j2,j3,j4))*za(j1,j5)*za(j4,j5)*
     .(za(j2,j4)*zb(j1,j2)+za(j3,j4)*zb(j1,j3)))/
     .(za(j1,j2)*za(j2,j3)*za(j3,j4)*za(j5,j6)*t(j2,j3,j4))

      return
      end


! ============================ Module Description ===========================
! PHI_MOD: Initilizes Phi functions for scaler arguments. Contains:
!   1. phi - initilizes phi functions using contour integral & recursion
!            relation.
! ===========================================================================

module phi_mod

    ! Module Parameters
    use pf_mod_dtype, only:  pfdp
    implicit none
    real(pfdp), parameter :: PI = 3.1415926535897932_pfdp
    complex(pfdp), parameter :: II = cmplx(0.0_pfdp,1.0_pfdp)

    ! Cauchy Integral Settings
    real(pfdp),   parameter :: c_tol = 1.0_pfdp         ! Smallest Lambda for contour integral
    real(pfdp),   parameter :: c_R   = 2.0_pfdp*c_tol   ! Contour Radius
    integer,      parameter :: c_M   = 32               ! Number of Points

    ! Interfaces For phi and phiw
    interface phi
        module procedure phi_zscalar, phi_zvector, phi_zmatrix,phi_zmatrix3d, phi_rscalar, phi_rvector, phi_rmatrix
    end interface

    contains

    ! === FUNCTIONS FOR REAL-VALUED L ===========================

    subroutine phi_rvector(L, n, P)
        ! Arguments
        real(pfdp),  intent(in)  :: L(:)
        integer,     intent(in) :: n
        real(pfdp),  intent(out) :: P(n+1,size(L))
        ! Local Variables
        integer :: i, m
        complex(pfdp), allocatable :: LC(:)
        complex(pfdp), allocatable :: PC(:, :)
        m = size(L)
        allocate(LC(m))
        allocate(PC(n+1, m))
        do i = 1, m
            LC(i) = CMPLX(L(i), 0, pfdp)
        end do
        call phi_zvector(LC, n, PC)
        P = real(PC)
    end subroutine phi_rvector

    subroutine phi_rscalar(L, n, P)
        ! Arguments
        real(pfdp), intent(in)  :: L
        integer,    intent(in)  :: n
        real(pfdp), intent(out) :: P(n+1)
        ! Local Variables
        real(pfdp) :: PM(n+1, 1)
        real(pfdp) :: LV(1)
        ! Pack Arguments for call to phi_vector
        LV(1) = L
        call phi_rvector(LV, n, PM)
        ! Unpack Result
        P = PM(:,1)
    end subroutine phi_rscalar

    subroutine phi_rmatrix(L, n, P)
        ! Arguments
        real(pfdp), intent(in)  :: L(:,:)
        integer,       intent(in)  :: n
        real(pfdp), intent(out) :: P(n + 1, size(L, 1), size(L, 2))
        ! Local Variables
        integer       :: Ln, Lm, d
        real(pfdp), allocatable :: PM(:, :)
        real(pfdp), allocatable :: LV(:)
        ! Pack Arguments for call to phi_vector
        Lm = size(L, 1)
        Ln = size(L, 2)
        d  = Lm * Ln
        allocate(LV(d))
        allocate(PM(n+1, d))
        LV = reshape(L, (/ d /))
        call phi_rvector(LV, n, PM)
        ! Unpack Result
        P = reshape(PM, (/n+1, Ln, Lm/))
    end subroutine phi_rmatrix

    ! === FUNCTIONS FOR COMPLEX-VALUED L ===========================

    subroutine phi_zscalar(L, n, P)
        ! Arguments
        complex(pfdp), intent(in)  :: L
        integer,       intent(in)  :: n
        complex(pfdp), intent(out) :: P(n+1)
        ! Local Variables
        complex(pfdp) :: PM(n+1, 1)
        complex(pfdp) :: LV(1)
        ! Pack Arguments for call to phi_vector
        LV(1) = L
        call phi_zvector(LV, n, PM)
        ! Unpack Result
        P = PM(:,1)
    end subroutine phi_zscalar

    subroutine phi_zmatrix(L, n, P)
        ! Arguments
        complex(pfdp), intent(in)  :: L(:,:)
        integer,       intent(in)  :: n
        complex(pfdp), intent(out) :: P(n + 1, size(L, 1), size(L, 2))
        ! Local Variables
        integer       :: Ln, Lm, d
        complex(pfdp), allocatable :: PM(:, :)
        complex(pfdp), allocatable :: LV(:)
        ! Pack Arguments for call to phi_vector
        Lm = size(L, 1)
        Ln = size(L, 2)
        d  = Lm * Ln
        allocate(LV(d))
        allocate(PM(n+1, d))
        LV = reshape(L, (/ d /))
        call phi_zvector(LV, n, PM)
        ! Unpack Result
        P = reshape(PM, (/n+1, Ln, Lm/))
    end subroutine phi_zmatrix

    subroutine phi_zmatrix3d(L, n, P)
        ! Arguments
        complex(pfdp), intent(in)  :: L(:,:,:)
        integer,       intent(in)  :: n
        complex(pfdp), intent(out) :: P(n + 1, size(L, 1), size(L, 2),size(L,3))
        ! Local Variables
        integer       :: Ln, Lm,Lp, d
        complex(pfdp), allocatable :: PM(:, :)
        complex(pfdp), allocatable :: LV(:)
        ! Pack Arguments for call to phi_vector
        Lm = size(L, 1)
        Ln = size(L, 2)
        Lp = size(L, 3)
        d  = Lm * Ln *Lp
        allocate(LV(d))
        allocate(PM(n+1, d))
        LV = reshape(L, (/ d /))
        call phi_zvector(LV, n, PM)
        ! Unpack Result
        P = reshape(PM, (/n+1, Ln, Lm,Lp/))
    end subroutine phi_zmatrix3d

    ! =======================================================================
    ! PHI   Evaluates \phi_i(L) for i=0,...,n and scaler/vector L using
    !       Recursion relation and Cauchy Integral Formula.
    !
    ! Arguments
    !
    !   L   (input) COMPLEX*16 array, dimensions(n)
    !       array of Lambda values cooresponding to PDE linear component
    !
    !   n   (input) INTEGER
    !       highest phi function to initialize.
    !
    !   P   (output) COMPLEX*16, dimensions(n,size(L))
    !       array where on exit P(i,j) = \phi_{i-1}(L(j))
    ! =======================================================================

    subroutine phi_zvector(L, n, P)
        ! Arguments
        complex(pfdp), intent(in)  :: L(:)
        integer,     intent(in)  :: n
        complex(pfdp), intent(out) :: P(n+1,size(L))
        ! Local Variables
        integer     :: i,j,k,nL
        real(pfdp)    :: f
        complex(pfdp) :: z(c_M)
        complex(pfdp) :: Li,Lzi,pp

        nL = size(L)
        P = 0;
        ! Set contour points
        do i=1,c_M
            z(i) = c_R * exp(2.0_pfdp*PI*II*(i-1.0_pfdp)/real(c_M,pfdp))
        enddo
        ! Compute Phi
        do i=1,nL
            Li = L(i)
            if(abs(Li) >= c_tol) then
                ! Direct Formula
                P(1,i) = exp(Li)
                f = 1.0_pfdp
                do j=2,n+1
                    P(j,i) = (P(j-1,i) - 1.0_pfdp/f)/Li
                    f = f*(j-1)
                enddo
            else
                ! Cauchy Integral Formula
                do k=1,c_M
                    Lzi = Li + z(k)
                    pp = exp(Lzi)
                    P(1,i) = P(1,i) + pp/c_M
                    f = 1.0_pfdp;
                    do j=2,n+1
                        pp = (pp - 1.0_pfdp/f)/Lzi
                        P(j,i) = P(j,i) + pp/c_M;
                        f = f*(j-1)
                    enddo
                enddo
                ! remove imaginary roundoff if L(i) is real
                if(aimag(Li) == 0.0_pfdp) then
                  P(:,i) = REAL(P(:,i))
                endif
            end if
        end do
end subroutine phi_zvector
  ! =======================================================================
  ! WEIGHTS   Compute coefficients for finite difference approximation for
  !           the derivatives 1 to m at point z assuming data is known at
  !           points in array x. Based on the program "weights" in
  !           B. Fornberg, "Calculation of weights in finite difference
  !           formulas", SIAM Review 40 (1998), pp. 685-691.
  ! Arguments
  !
  !   z   (input) DOUBLE
  !       location where approximations are to be accurate
  !
  !   x   (input) DOUBLE Array
  !       array containing interpolation points
  !
  !   m   (input) INTEGER
  !       highest derivative for which weights are sought
  !
  !   W   (output) DOUBLE array, dimension(size(x),m+1)
  !       matrix that gives weights at grid locations x for
  !       derivative of order j<=m are found in c(:,j)
  ! =======================================================================

  subroutine weights(z, x, m, W)

    ! Arguments
    real(pfdp), intent(in)    :: z
    real(pfdp), intent(inout)    :: x(:)
    integer,    intent(in)    :: m
    real(pfdp), intent(out)   :: W(m+1,m+1)

    ! Variable Declarations
    real(pfdp) :: c1, c2, c3, c4, c5
    integer  :: ii,i,j,k,n,mn

    c1 = 1.0_pfdp
    c4 = x(1) - z
    W  = 0.0_pfdp
    W(1,1) = 1.0_pfdp

    n = SIZE(x)
    do i=2,n
      mn = min(i,m+1)
      c2 = 1.0_pfdp
      c5 = c4
      c4 = x(i) - z
      do j=1,i-1
        c3 = x(i) - x(j)
        c2 = c2*c3;
        if(j == i-1) then
          do k=mn,2,-1
            W(i,k) = c1*(REAL(k-1,pfdp)*W(i-1,k-1) - c5*W(i-1,k))/c2;
          enddo

          W(i,1) = -c1*c5*W(i-1,1)/c2;
        endif
        do k=mn,2,-1
          W(j,k) = (c4*W(j,k) - REAL(k-1,pfdp)*W(j,k-1))/c3;
        enddo
        W(j,1) = c4*W(j,1)/c3;
      enddo
      c1 = c2;
    enddo
    !        end do

  end subroutine weights

end module phi_mod