c
c     file tmud3cr.f
c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1999 by UCAR                 .
c  .                                                             .
c  .       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                      MUDPACK version 5.0                    .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c ... author and specialist
c
c          John C. Adams (National Center for Atmospheric Research)
c          email: johnad@ucar.edu, phone: 303-497-1213

c ... For MUDPACK 5.0 information, visit the website:
c     (http://www.scd.ucar.edu/css/software/mudpack)
c
c
c ... purpose
c
c     test program for the MUDPACK solver mud3cr
c
c ... required MUDPACK files
c
c     mud3cr.f, mudcom.f
c
c
c *********************************************************
c *********************************************************
c
c     sample program/test driver for mud3cr (see mud3cr.d)
c
c **********************************************************
c **********************************************************
c
c     a sample program/test driver for mud3cr is below. it can be
c     executed as an initial test.  The output from executing
c     the code in this file is listed after the problem description.
c
c     Problem Description:
c
c     test mud3cr by solving the nonseparable 3-d elliptic pde
c     with cross derivative terms:
c
c          cxx*pxx + cyy*pyy + czz*pzz + cx*px + cy*py + cz*pz + ce*pe +
c
c          cxy*pxy + cxz*pxz + cyz*pyz = r(x,y,z).
c
c     on the region 0 < x < 1, 0 < y < (pi+pi), 0 < z < 1.
c     let s = sin(y).  the coefficients are given by:
c
c          cxx = 1.0+0.5*s*z, cyy = 1+x*z, czz = 1+0.5*s*x
c
c          cx = 0.0, cy = -x*z, cz = 0.0, ce = -(x+z)
c
c          cxy = sqrt(cxx*cyy), cxz = 0.0, cyz = sqrt(cyy*czz)
c
c     assume the solution is periodic in y and is specified at x=0 and z=0.
c     further assume mixed oblique derivative conditions of the form
c
c          px + (z*(1-z))*py + sin(y)*cos(y)*pz - p(1,y,z) = g(y,z)
c
c     at x=1 and mixed normal derivative conditions of the form
c
c          pz + x*s*s*p(x,y,1)  = h(x,y)
c
c     at z=1.  for testing purposes use the exact solution
c
c          p(x,y,z) = (x*cos(y)*z)**3
c
c     to set boundary conditions, the right hand side, and compute
c     exact error.  results from approximating this problem on a
c     25 X 129 X 25 and a 49 X 257 X 49 grid using mud3cr are given
c     Gauss-Seidel red/black point relaxation and an error tolerance
c     of 0.001 are used.
c
c ******************************************************
c     output
c *******************************************************
c
c *** 25 X 129 X 25 grid (32 bit floating point arithmetic)
c
c     mud3cr test
c
c     input arguments
c     intl =  0
c     nxa =  1 nxb =  2
c     nyc =  0 nyd =  0
c     nze =  1 nzf =  2
c     ixp =  3 jyq =  2 kzr =  3
c     iex =  4 jey =  7 kez =  4
c     nx =  25 ny = 129 nz =  25
c     iguess =  0 maxcy =  2
c     method =  0 work space input = 1176431
c     xa =  0.00 xb =  1.00
c     yc =  0.00 yd =  6.28
c     ze =  0.00 zf =  1.00
c     tolmax =  0.000E+00
c
c     multigrid options
c     mgopt(1)  =  0
c
c     new mud3cr arguments
c     icrs
c        1    0    1
c     tol = 0.0010
c     maxit =  10
c
c     initial call
c     intl =  0
c     iguess =  0
c     ierror =  0
c     minimum required work space length =  1176431
c
c     approximation call
c     intl =  1
c     iguess =  0
c     ierror =   0
c     number of outer iterations executed =   8
c     relative difference profile:
c     0.2694  0.0853  0.0357  0.0135  0.0075  0.0031  0.0016  0.0008
c     exact least squares error =  0.228E-03
c
c
c *** 49 X 257 X 49 grid (64 bit floating point arithmetic)
c
c     mud3cr test
c
c     input arguments
c     intl =  0
c     nxa =  1 nxb =  2
c     nyc =  0 nyd =  0
c     nze =  1 nzf =  2
c     ixp =  3 jyq =  2 kzr =  3
c     iex =  5 jey =  8 kez =  5
c     nx =  49 ny = 257 nz =  49
c     iguess =  0 maxcy =  2
c     method =  0 work space input = 8680868
c     xa =  0.00 xb =  1.00
c     yc =  0.00 yd =  6.28
c     ze =  0.00 zf =  1.00
c     tolmax =  0.000E+00
c
c     multigrid options
c     mgopt(1)  =  0
c
c     new mud3cr arguments
c     icrs
c        1    0    1
c     tol = 0.0010
c     maxit =  10
c
c     initial call
c     intl =  0
c     iguess =  0
c     ierror =  0
c     minimum required work space length =  8680868
c
c     approximation call
c     intl =  1
c     iguess =  0
c     ierror =   0
c     number of outer iterations executed =   6
c     0.1297  0.0411  0.0121  0.0053  0.0028  0.0008
c     exact least squares error =  0.499E-04
c
c ************************************************************
c     end of output
c ************************************************************
c
      program tmd3cr
      implicit none
c
c     set grid sizes and predetermined minimal required equired work
c     with parameter statements
c
      integer iixp,jjyq,kkzr,iiex,jjey,kkez,nnx,nny,nnz,llengt,mmaxit
      parameter(iixp=3 ,jjyq=2,kkzr=3 )
c *** 25 X 129 X 25 grid parameters
      parameter(iiex=4,jjey=7,kkez=4)
      parameter(llengt=1176431)
c *** 49 X 257 X 49 grid parameters
c     parameter(iiex=5,jjey=8,kkez=5)
c     parameter (llengt = 8680868)
      parameter(nnx = iixp*2**(iiex-1)+1)
      parameter(nny = jjyq*2**(jjey-1)+1)
      parameter(nnz = kkzr*2**(kkez-1)+1)
      parameter(mmaxit = 10)
      real rhs(nnx,nny,nnz),phi(nnx,nny,nnz)
      integer iparm(23),mgopt(4),icrs(3)
      integer i,j,k,ierror,maxit,iouter
      real work(llengt),fparm(8),rmax(mmaxit)
c
c     use labelled common to identify integer and floating point arguments
c
      integer intl,nxa,nxb,nyc,nyd,nze,nzf,ixp,jyq,kzr,iex,jey,
     +kez,nx,ny,nz,iguess,maxcy,method,meth2,nwork,lwkmin,itero
      common /iprm/intl,nxa,nxb,nyc,nyd,nze,nzf,ixp,jyq,kzr,iex,jey,
     +kez,nx,ny,nz,iguess,maxcy,method,meth2,nwork,lwkmin,itero
      real xa,xb,yc,yd,ze,zf,tolmax,relmax
      common/fprm/xa,xb,yc,yd,ze,zf,tolmax,relmax
      real pi,dx,dy,dz,c,s,x,y,z,tol,err2
      real cxx,cyy,czz,cx,cy,cz,ce,cxy,cyz
      real pxx,pyy,pzz,px,py,pz,pxy,pxz,pyz,pe
      equivalence(iparm,intl)
      equivalence(fparm,xa)
      external cof,bd3cr,cxyf,cxzf,cyzf
      pi = 4.*atan(1.)
c
c     set interval end points
c
      xa = 0.0
      xb = 1.0
      yc = 0.0
      yd = pi+pi
      ze = 0.0
      zf = 1.0
c
c     set required no error control within multigrid cycling
c
      tolmax = 0.0
c
c     set integer input arguments
c
      intl = 0
c
c     set boundary condition flags
c
      nxa = 1
      nxb = 2
      nyc = 0
      nyd = 0
      nze = 1
      nzf = 2
c
c     set grid size arguments from parameter statements
c
      ixp = iixp
      jyq = jjyq
      kzr = kkzr
      iex = iiex
      jey = jjey
      kez = kkez
      nx = nnx
      ny = nny
      nz = nnz
c
c     flag nonzero xy and yz and zero xz cross derivatives terms
c
      icrs(1) = 1
      icrs(2) = 0
      icrs(3) = 1
c
c     set two multigrid cycles per outer iteration
c
      maxcy = 2
c
c     set point relaxation
c
      method = 0
      meth2 = 0
c
c     set work space length input
c
      nwork = llengt
c
c     set uniform grid interval lengths in each dimension
c
      dx = (xb-xa)/(nx-1)
      dy = (yd-yc)/(ny-1)
      dz = (zf-ze)/(nz-1)
c
c     set right hand side and preset solution to zero
c     this also sets specified (Dirchlet) b.c. in phi
c
      do j=1,ny
	y = (j-1)*dy
	s = sin(y)
	do k=1,nz
	  z = (k-1)*dz
	  do i=1,nx
	    x = (i-1)*dx
	    call exact(x,y,z,pe,px,py,pz,pxx,pyy,pzz,pxy,pxz,pyz)
	    call cof(x,y,z,cxx,cyy,czz,cx,cy,cz,ce)
	    call cxyf(x,y,z,cxy)
	    call cyzf(x,y,z,cyz)
	    rhs(i,j,k) = cxx*pxx+cyy*pyy+czz*pzz+cxy*pxy+cyz*pyz+
     +                   cx*px+cy*py+cz*pz+ce*pe
	    phi(i,j,k) = 0.0
	  end do
	end do
      end do
c
c     set default multigrid options
c
      mgopt(1) = 0
c
c     set error control tolerance and outer iteration limit of 10
c
      tol = .001
      maxit = mmaxit
c
c     print input arguments shared with mud3
c
      write(*,50)
   50 format(//' mud3cr test ' )
      write(6,100)intl,nxa,nxb,nyc,nyd,nze,nzf,ixp,jyq,kzr,iex,jey,kez,
     +            nx,ny,nz,iguess,maxcy,method,nwork,xa,xb,yc,yd,ze,zf,
     +            tolmax,mgopt(1)
  100 format(/' input arguments ',
     +/' intl = ',i2,
     +/' nxa = ',i2,' nxb = ',i2,
     +/' nyc = ',i2,' nyd = ',i2,
     +/' nze = ',i2,' nzf = ',i2,
     +/' ixp = ',i2,' jyq = ',i2,' kzr = ',i2,
     +/' iex = ',i2, ' jey = ',i2, ' kez = ',i2,
     +/' nx = ',i3,' ny = ',i3,' nz = ',i3,
     +/' iguess = ',i2,' maxcy = ',i2,
     +/' method = ',i2, ' work space input = ',i7,
     +/' xa = ',f5.2,' xb = ',f5.2,
     +/' yc = ',f5.2,' yd = ',f5.2,
     +/' ze = ',f5.2,' zf = ',f5.2,
     +/' tolmax = ' ,e10.3
     +//' multigrid options '
     +/' mgopt(1)  = ',i2)
c
c     print new mud3cr arguments
c
      write(*,101) (icrs(i),i=1,3),tol,maxit
  101 format(/' new mud3cr arguments ', / ' icrs '/ 3i5,
     +/' tol = ',f6.4 /' maxit = ',i3)
c
c *** initialization call
c
      intl = 0
      iguess = 0
      call mud3cr(iparm,fparm,work,cof,bd3cr,rhs,phi,mgopt,icrs,
     +cxyf,cxzf,cyzf,tol,maxit,iouter,rmax,ierror)
      write (6,200) intl,iguess,ierror,iparm(22)
  200 format(/' initial call', /' intl = ',i2, /' iguess = ',i2,
     +/' ierror = ',i2, /' minimum required work space length = ',i8)
      if (ierror.gt.0) call exit(0)
c
c *** noninitial call
c
      intl = 1
      iguess = 0
      call mud3cr(iparm,fparm,work,cof,bd3cr,rhs,phi,mgopt,icrs,
     +cxyf,cxzf,cyzf,tol,maxit,iouter,rmax,ierror)
      write (6,201) intl,iguess,ierror,iouter,(rmax(i),i=1,iouter)
  201 format(/' approximation call ', /' intl = ',i2, /' iguess = ',i2,
     +/' ierror = ',i3,
     +/' number of outer iterations executed = ',i3,
     +/' relative difference profile:', /(10(f6.4,2x)))
c
c     compute and print exact least squares error after iouter iterations
c
      err2 = 0.
      do j=1,ny
	y = (j-1)*dy
	c = cos(y)
	do k=1,nz
	  z = (k-1)*dz
	  do i=1,nx
	    x = (i-1)*dx
	    pe = (x*c*z)**3
	    err2 = err2 + (pe - phi(i,j,k))**2
	  end do
	end do
      end do
      err2 = sqrt(err2/(nx*ny*nz))
      write(6,202) err2
  202 format(' exact least squares error = ',e10.3)

      end

      subroutine exact(x,y,z,pe,px,py,pz,pxx,pyy,pzz,pxy,pxz,pyz)
c
c     set exact solution and partial derivatives: p(x,y,z) = (x*cos(y)*z)**3
c
      implicit none
      real x,y,z,pe,px,py,pz,pxx,pyy,pzz,pxy,pxz,pyz
      real s,c,xc,xz,cz,xcz
      c = cos(y)
      s = sin(y)
      xc = x*c
      xz = x*z
      cz = c*z
      xcz = xc*z
      pe = xcz**3
      px = 3.*x*x*cz**3
      pxx = 6.*x*cz**3
      py = -3.*c*c*s*xz**3
      pyy = -3.*xz**3*(c**3-2.*c*s**2)
      pz = 3.*z*z*xc**3
      pzz = 6.*z*xc**3
      pxy = -9.*x**2*c*c*s*z**3
      pxz = 9.*xz**2*c**3
      pyz = -9.*c*c*s*x**3*z**2
      return
      end

      subroutine cof(x,y,z,cxx,cyy,czz,cx,cy,cz,ce)
c
c     set noncross derivative pde coefficients
c
      implicit none
      real x,y,z,cxx,cyy,czz,cx,cy,cz,ce,s
      s = sin(y)
      cxx = 1.+0.5*s*z
      cyy = 1.+x*z
      czz = 1.+0.5*x*s
      cx = 0.0
      cy = -x*z
      cz = 0.0
      ce = -(x+z)
      return
      end

      subroutine cxyf(x,y,z,cxy)
c
c     set x-y cross term coefficient at (x,y,z)
c
      implicit none
      real x,y,z,cxx,cyy,czz,cx,cy,cz,ce,cxy
      call cof(x,y,z,cxx,cyy,czz,cx,cy,cz,ce)
      cxy = sqrt(cxx*cyy)
      return
      end

      subroutine cxzf(x,y,z,cxz)
c
c     this is a dummy subroutine since cxz=0.0 for all (x,y,z)
c
      return
      end

      subroutine cyzf(x,y,z,cyz)
c
c     set y-z cross term coefficient at (x,y,z)
c
      implicit none
      real x,y,z,cxx,cyy,czz,cx,cy,cz,ce,cyz
      call cof(x,y,z,cxx,cyy,czz,cx,cy,cz,ce)
      cyz = sqrt(cyy*czz)
      return
      end

      subroutine bd3cr(kbdy,xory,yorz,a,b,c,g)
c
c     pass mixed derivative boundary conditions to mud3cr
c
      implicit none
      integer kbdy
      real xory,yorz,a,b,c,g,x,y,z
      real pe,px,py,pz,pxx,pyy,pzz,pxy,pxz,pyz
      if (kbdy.eq.2) then
c
c     upper x boundary (mixed oblique)
c
	x = 1.0
	y = xory
	z = yorz
	a = (z*(1.-z))
	b = sin(y)*cos(y)
	c = -1.0
	call exact(x,y,z,pe,px,py,pz,pxx,pyy,pzz,pxy,pxz,pyz)
	g = px + a*py + b*pz + c*pe
	return
      else if (kbdy.eq.6) then
c
c     upper z boundary (mixed normal)
c
	z = 1.0
	x = xory
	y = yorz
	a = 0.0
	b = 0.0
	c = x*sin(y)**2
	call exact(x,y,z,pe,px,py,pz,pxx,pyy,pzz,pxy,pxz,pyz)
	g = pz + a*px + b*py + c*pe
	return
      end if
      end


!*==cblat1.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
!> \brief \b CBLAT1
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       PROGRAM CBLAT1
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!>    Test program for the COMPLEX Level 1 BLAS.
!>    Based upon the original BLAS test routine together with:
!>
!>    F06GAF Example Program Text
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date April 2012
!
!> \ingroup complex_blas_testing
!
!  =====================================================================
      PROGRAM CBLAT1
      IMPLICIT NONE
!*--CBLAT141
!
!  -- Reference BLAS test routine (version 3.7.0) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     April 2012
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER NOUT
      PARAMETER (NOUT=6)
!     .. Scalars in Common ..
      INTEGER ICAse , INCx , INCy , MODe , N
      LOGICAL PASs
!     .. Local Scalars ..
      REAL sfac
      INTEGER ic
!     .. External Subroutines ..
      EXTERNAL CHECK1 , CHECK2 , HEADER
!     .. Common blocks ..
      COMMON /COMBLA/ ICAse , N , INCx , INCy , MODe , PASs
!     .. Data statements ..
      DATA sfac/9.765625E-4/
!     .. Executable Statements ..
      WRITE (NOUT,99001)
!
99001 FORMAT (' Complex BLAS Test Program Results',/1X)
      DO ic = 1 , 10
         ICAse = ic
         CALL HEADER
!
!        Initialize PASS, INCX, INCY, and MODE for a new case.
!        The value 9999 for INCX, INCY or MODE will appear in the
!        detailed  output, if any, for cases that do not involve
!        these parameters.
!
         PASs = .TRUE.
         INCx = 9999
         INCy = 9999
         MODe = 9999
         IF ( ICAse<=5 ) THEN
            CALL CHECK2(sfac)
         ELSEIF ( ICAse>=6 ) THEN
            CALL CHECK1(sfac)
         ENDIF
!        -- Print
         IF ( PASs ) WRITE (NOUT,99002)
99002    FORMAT ('                                    ----- PASS -----')
      ENDDO
      STOP
      END PROGRAM CBLAT1
!*==header.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      SUBROUTINE HEADER
      IMPLICIT NONE
!*--HEADER96
!     .. Parameters ..
      INTEGER NOUT
      PARAMETER (NOUT=6)
!     .. Scalars in Common ..
      INTEGER ICAse , INCx , INCy , MODe , N
      LOGICAL PASs
!     .. Local Arrays ..
      CHARACTER*6 l(10)
!     .. Common blocks ..
      COMMON /COMBLA/ ICAse , N , INCx , INCy , MODe , PASs
!     .. Data statements ..
      DATA l(1)/'CDOTC '/
      DATA l(2)/'CDOTU '/
      DATA l(3)/'CAXPY '/
      DATA l(4)/'CCOPY '/
      DATA l(5)/'CSWAP '/
      DATA l(6)/'SCNRM2'/
      DATA l(7)/'SCASUM'/
      DATA l(8)/'CSCAL '/
      DATA l(9)/'CSSCAL'/
      DATA l(10)/'ICAMAX'/
!     .. Executable Statements ..
      WRITE (NOUT,99001) ICAse , l(ICAse)
!
99001 FORMAT (/' Test of subprogram number',I3,12X,A6)
      RETURN
      END SUBROUTINE HEADER
!*==check1.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      SUBROUTINE CHECK1(Sfac)
      IMPLICIT NONE
!*--CHECK1127
!     .. Parameters ..
      INTEGER NOUT
      PARAMETER (NOUT=6)
!     .. Scalar Arguments ..
      REAL Sfac
!     .. Scalars in Common ..
      INTEGER ICAse , INCx , INCy , MODe , N
      LOGICAL PASs
!     .. Local Scalars ..
      COMPLEX ca
      REAL sa
      INTEGER i , ix , j , len , np1
!     .. Local Arrays ..
      COMPLEX ctrue5(8,5,2) , ctrue6(8,5,2) , cv(8,5,2) , cvr(8) ,      &
     &        cx(8) , cxr(15) , mwpcs(5) , mwpct(5)
      REAL strue2(5) , strue4(5)
      INTEGER itrue3(5) , itruec(5)
!     .. External Functions ..
      REAL SCASUM , SCNRM2
      INTEGER ICAMAX
      EXTERNAL SCASUM , SCNRM2 , ICAMAX
!     .. External Subroutines ..
      EXTERNAL CSCAL , CSSCAL , CTEST , ITEST1 , STEST1
!     .. Intrinsic Functions ..
      INTRINSIC MAX
!     .. Common blocks ..
      COMMON /COMBLA/ ICAse , N , INCx , INCy , MODe , PASs
!     .. Data statements ..
      DATA sa , ca/0.3E0 , (0.4E0,-0.7E0)/
      DATA ((cv(i,j,1),i=1,8),j=1,5)/(0.1E0,0.1E0) , (1.0E0,2.0E0) ,    &
     &      (1.0E0,2.0E0) , (1.0E0,2.0E0) , (1.0E0,2.0E0) ,             &
     &      (1.0E0,2.0E0) , (1.0E0,2.0E0) , (1.0E0,2.0E0) ,             &
     &      (0.3E0,-0.4E0) , (3.0E0,4.0E0) , (3.0E0,4.0E0) ,            &
     &      (3.0E0,4.0E0) , (3.0E0,4.0E0) , (3.0E0,4.0E0) ,             &
     &      (3.0E0,4.0E0) , (3.0E0,4.0E0) , (0.1E0,-0.3E0) ,            &
     &      (0.5E0,-0.1E0) , (5.0E0,6.0E0) , (5.0E0,6.0E0) ,            &
     &      (5.0E0,6.0E0) , (5.0E0,6.0E0) , (5.0E0,6.0E0) ,             &
     &      (5.0E0,6.0E0) , (0.1E0,0.1E0) , (-0.6E0,0.1E0) ,            &
     &      (0.1E0,-0.3E0) , (7.0E0,8.0E0) , (7.0E0,8.0E0) ,            &
     &      (7.0E0,8.0E0) , (7.0E0,8.0E0) , (7.0E0,8.0E0) ,             &
     &      (0.3E0,0.1E0) , (0.5E0,0.0E0) , (0.0E0,0.5E0) ,             &
     &      (0.0E0,0.2E0) , (2.0E0,3.0E0) , (2.0E0,3.0E0) ,             &
     &      (2.0E0,3.0E0) , (2.0E0,3.0E0)/
      DATA ((cv(i,j,2),i=1,8),j=1,5)/(0.1E0,0.1E0) , (4.0E0,5.0E0) ,    &
     &      (4.0E0,5.0E0) , (4.0E0,5.0E0) , (4.0E0,5.0E0) ,             &
     &      (4.0E0,5.0E0) , (4.0E0,5.0E0) , (4.0E0,5.0E0) ,             &
     &      (0.3E0,-0.4E0) , (6.0E0,7.0E0) , (6.0E0,7.0E0) ,            &
     &      (6.0E0,7.0E0) , (6.0E0,7.0E0) , (6.0E0,7.0E0) ,             &
     &      (6.0E0,7.0E0) , (6.0E0,7.0E0) , (0.1E0,-0.3E0) ,            &
     &      (8.0E0,9.0E0) , (0.5E0,-0.1E0) , (2.0E0,5.0E0) ,            &
     &      (2.0E0,5.0E0) , (2.0E0,5.0E0) , (2.0E0,5.0E0) ,             &
     &      (2.0E0,5.0E0) , (0.1E0,0.1E0) , (3.0E0,6.0E0) ,             &
     &      (-0.6E0,0.1E0) , (4.0E0,7.0E0) , (0.1E0,-0.3E0) ,           &
     &      (7.0E0,2.0E0) , (7.0E0,2.0E0) , (7.0E0,2.0E0) ,             &
     &      (0.3E0,0.1E0) , (5.0E0,8.0E0) , (0.5E0,0.0E0) ,             &
     &      (6.0E0,9.0E0) , (0.0E0,0.5E0) , (8.0E0,3.0E0) ,             &
     &      (0.0E0,0.2E0) , (9.0E0,4.0E0)/
      DATA cvr/(8.0E0,8.0E0) , (-7.0E0,-7.0E0) , (9.0E0,9.0E0) ,        &
     &     (5.0E0,5.0E0) , (9.0E0,9.0E0) , (8.0E0,8.0E0) , (7.0E0,7.0E0)&
     &     , (7.0E0,7.0E0)/
      DATA strue2/0.0E0 , 0.5E0 , 0.6E0 , 0.7E0 , 0.8E0/
      DATA strue4/0.0E0 , 0.7E0 , 1.0E0 , 1.3E0 , 1.6E0/
      DATA ((ctrue5(i,j,1),i=1,8),j=1,5)/(0.1E0,0.1E0) , (1.0E0,2.0E0) ,&
     &      (1.0E0,2.0E0) , (1.0E0,2.0E0) , (1.0E0,2.0E0) ,             &
     &      (1.0E0,2.0E0) , (1.0E0,2.0E0) , (1.0E0,2.0E0) ,             &
     &      (-0.16E0,-0.37E0) , (3.0E0,4.0E0) , (3.0E0,4.0E0) ,         &
     &      (3.0E0,4.0E0) , (3.0E0,4.0E0) , (3.0E0,4.0E0) ,             &
     &      (3.0E0,4.0E0) , (3.0E0,4.0E0) , (-0.17E0,-0.19E0) ,         &
     &      (0.13E0,-0.39E0) , (5.0E0,6.0E0) , (5.0E0,6.0E0) ,          &
     &      (5.0E0,6.0E0) , (5.0E0,6.0E0) , (5.0E0,6.0E0) ,             &
     &      (5.0E0,6.0E0) , (0.11E0,-0.03E0) , (-0.17E0,0.46E0) ,       &
     &      (-0.17E0,-0.19E0) , (7.0E0,8.0E0) , (7.0E0,8.0E0) ,         &
     &      (7.0E0,8.0E0) , (7.0E0,8.0E0) , (7.0E0,8.0E0) ,             &
     &      (0.19E0,-0.17E0) , (0.20E0,-0.35E0) , (0.35E0,0.20E0) ,     &
     &      (0.14E0,0.08E0) , (2.0E0,3.0E0) , (2.0E0,3.0E0) ,           &
     &      (2.0E0,3.0E0) , (2.0E0,3.0E0)/
      DATA ((ctrue5(i,j,2),i=1,8),j=1,5)/(0.1E0,0.1E0) , (4.0E0,5.0E0) ,&
     &      (4.0E0,5.0E0) , (4.0E0,5.0E0) , (4.0E0,5.0E0) ,             &
     &      (4.0E0,5.0E0) , (4.0E0,5.0E0) , (4.0E0,5.0E0) ,             &
     &      (-0.16E0,-0.37E0) , (6.0E0,7.0E0) , (6.0E0,7.0E0) ,         &
     &      (6.0E0,7.0E0) , (6.0E0,7.0E0) , (6.0E0,7.0E0) ,             &
     &      (6.0E0,7.0E0) , (6.0E0,7.0E0) , (-0.17E0,-0.19E0) ,         &
     &      (8.0E0,9.0E0) , (0.13E0,-0.39E0) , (2.0E0,5.0E0) ,          &
     &      (2.0E0,5.0E0) , (2.0E0,5.0E0) , (2.0E0,5.0E0) ,             &
     &      (2.0E0,5.0E0) , (0.11E0,-0.03E0) , (3.0E0,6.0E0) ,          &
     &      (-0.17E0,0.46E0) , (4.0E0,7.0E0) , (-0.17E0,-0.19E0) ,      &
     &      (7.0E0,2.0E0) , (7.0E0,2.0E0) , (7.0E0,2.0E0) ,             &
     &      (0.19E0,-0.17E0) , (5.0E0,8.0E0) , (0.20E0,-0.35E0) ,       &
     &      (6.0E0,9.0E0) , (0.35E0,0.20E0) , (8.0E0,3.0E0) ,           &
     &      (0.14E0,0.08E0) , (9.0E0,4.0E0)/
      DATA ((ctrue6(i,j,1),i=1,8),j=1,5)/(0.1E0,0.1E0) , (1.0E0,2.0E0) ,&
     &      (1.0E0,2.0E0) , (1.0E0,2.0E0) , (1.0E0,2.0E0) ,             &
     &      (1.0E0,2.0E0) , (1.0E0,2.0E0) , (1.0E0,2.0E0) ,             &
     &      (0.09E0,-0.12E0) , (3.0E0,4.0E0) , (3.0E0,4.0E0) ,          &
     &      (3.0E0,4.0E0) , (3.0E0,4.0E0) , (3.0E0,4.0E0) ,             &
     &      (3.0E0,4.0E0) , (3.0E0,4.0E0) , (0.03E0,-0.09E0) ,          &
     &      (0.15E0,-0.03E0) , (5.0E0,6.0E0) , (5.0E0,6.0E0) ,          &
     &      (5.0E0,6.0E0) , (5.0E0,6.0E0) , (5.0E0,6.0E0) ,             &
     &      (5.0E0,6.0E0) , (0.03E0,0.03E0) , (-0.18E0,0.03E0) ,        &
     &      (0.03E0,-0.09E0) , (7.0E0,8.0E0) , (7.0E0,8.0E0) ,          &
     &      (7.0E0,8.0E0) , (7.0E0,8.0E0) , (7.0E0,8.0E0) ,             &
     &      (0.09E0,0.03E0) , (0.15E0,0.00E0) , (0.00E0,0.15E0) ,       &
     &      (0.00E0,0.06E0) , (2.0E0,3.0E0) , (2.0E0,3.0E0) ,           &
     &      (2.0E0,3.0E0) , (2.0E0,3.0E0)/
      DATA ((ctrue6(i,j,2),i=1,8),j=1,5)/(0.1E0,0.1E0) , (4.0E0,5.0E0) ,&
     &      (4.0E0,5.0E0) , (4.0E0,5.0E0) , (4.0E0,5.0E0) ,             &
     &      (4.0E0,5.0E0) , (4.0E0,5.0E0) , (4.0E0,5.0E0) ,             &
     &      (0.09E0,-0.12E0) , (6.0E0,7.0E0) , (6.0E0,7.0E0) ,          &
     &      (6.0E0,7.0E0) , (6.0E0,7.0E0) , (6.0E0,7.0E0) ,             &
     &      (6.0E0,7.0E0) , (6.0E0,7.0E0) , (0.03E0,-0.09E0) ,          &
     &      (8.0E0,9.0E0) , (0.15E0,-0.03E0) , (2.0E0,5.0E0) ,          &
     &      (2.0E0,5.0E0) , (2.0E0,5.0E0) , (2.0E0,5.0E0) ,             &
     &      (2.0E0,5.0E0) , (0.03E0,0.03E0) , (3.0E0,6.0E0) ,           &
     &      (-0.18E0,0.03E0) , (4.0E0,7.0E0) , (0.03E0,-0.09E0) ,       &
     &      (7.0E0,2.0E0) , (7.0E0,2.0E0) , (7.0E0,2.0E0) ,             &
     &      (0.09E0,0.03E0) , (5.0E0,8.0E0) , (0.15E0,0.00E0) ,         &
     &      (6.0E0,9.0E0) , (0.00E0,0.15E0) , (8.0E0,3.0E0) ,           &
     &      (0.00E0,0.06E0) , (9.0E0,4.0E0)/
      DATA itrue3/0 , 1 , 2 , 2 , 2/
      DATA itruec/0 , 1 , 1 , 1 , 1/
!     .. Executable Statements ..
      DO INCx = 1 , 2
         DO np1 = 1 , 5
            N = np1 - 1
            len = 2*MAX(N,1)
!           .. Set vector arguments ..
            DO i = 1 , len
               cx(i) = cv(i,np1,INCx)
            ENDDO
            IF ( ICAse==6 ) THEN
!              .. SCNRM2 ..
               CALL STEST1(SCNRM2(N,cx,INCx),strue2(np1),strue2(np1),   &
     &                     Sfac)
            ELSEIF ( ICAse==7 ) THEN
!              .. SCASUM ..
               CALL STEST1(SCASUM(N,cx,INCx),strue4(np1),strue4(np1),   &
     &                     Sfac)
            ELSEIF ( ICAse==8 ) THEN
!              .. CSCAL ..
               CALL CSCAL(N,ca,cx,INCx)
               CALL CTEST(len,cx,ctrue5(1,np1,INCx),ctrue5(1,np1,INCx), &
     &                    Sfac)
            ELSEIF ( ICAse==9 ) THEN
!              .. CSSCAL ..
               CALL CSSCAL(N,sa,cx,INCx)
               CALL CTEST(len,cx,ctrue6(1,np1,INCx),ctrue6(1,np1,INCx), &
     &                    Sfac)
            ELSEIF ( ICAse==10 ) THEN
!              .. ICAMAX ..
               CALL ITEST1(ICAMAX(N,cx,INCx),itrue3(np1))
               DO i = 1 , len
                  cx(i) = (42.0E0,43.0E0)
               ENDDO
               CALL ITEST1(ICAMAX(N,cx,INCx),itruec(np1))
            ELSE
               WRITE (NOUT,*) ' Shouldn''t be here in CHECK1'
               STOP
            ENDIF
!
         ENDDO
         IF ( ICAse==10 ) THEN
            N = 8
            ix = 1
            DO i = 1 , N
               cxr(ix) = cvr(i)
               ix = ix + INCx
            ENDDO
            CALL ITEST1(ICAMAX(N,cxr,INCx),3)
         ENDIF
      ENDDO
!
      INCx = 1
      IF ( ICAse==8 ) THEN
!        CSCAL
!        Add a test for alpha equal to zero.
         ca = (0.0E0,0.0E0)
         DO i = 1 , 5
            mwpct(i) = (0.0E0,0.0E0)
            mwpcs(i) = (1.0E0,1.0E0)
         ENDDO
         CALL CSCAL(5,ca,cx,INCx)
         CALL CTEST(5,cx,mwpct,mwpcs,Sfac)
      ELSEIF ( ICAse==9 ) THEN
!        CSSCAL
!        Add a test for alpha equal to zero.
         sa = 0.0E0
         DO i = 1 , 5
            mwpct(i) = (0.0E0,0.0E0)
            mwpcs(i) = (1.0E0,1.0E0)
         ENDDO
         CALL CSSCAL(5,sa,cx,INCx)
         CALL CTEST(5,cx,mwpct,mwpcs,Sfac)
!        Add a test for alpha equal to one.
         sa = 1.0E0
         DO i = 1 , 5
            mwpct(i) = cx(i)
            mwpcs(i) = cx(i)
         ENDDO
         CALL CSSCAL(5,sa,cx,INCx)
         CALL CTEST(5,cx,mwpct,mwpcs,Sfac)
!        Add a test for alpha equal to minus one.
         sa = -1.0E0
         DO i = 1 , 5
            mwpct(i) = -cx(i)
            mwpcs(i) = -cx(i)
         ENDDO
         CALL CSSCAL(5,sa,cx,INCx)
         CALL CTEST(5,cx,mwpct,mwpcs,Sfac)
      ENDIF
      END SUBROUTINE CHECK1
!*==check2.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      SUBROUTINE CHECK2(Sfac)
      IMPLICIT NONE
!*--CHECK2341
!     .. Parameters ..
      INTEGER NOUT
      PARAMETER (NOUT=6)
!     .. Scalar Arguments ..
      REAL Sfac
!     .. Scalars in Common ..
      INTEGER ICAse , INCx , INCy , MODe , N
      LOGICAL PASs
!     .. Local Scalars ..
      COMPLEX ca
      INTEGER i , j , ki , kn , ksize , lenx , leny , lincx , lincy ,   &
     &        mx , my
!     .. Local Arrays ..
      COMPLEX cdot(1) , csize1(4) , csize2(7,2) , csize3(14) ,          &
     &        ct10x(7,4,4) , ct10y(7,4,4) , ct6(4,4) , ct7(4,4) ,       &
     &        ct8(7,4,4) , cty0(1) , cx(7) , cx0(1) , cx1(7) , cy(7) ,  &
     &        cy0(1) , cy1(7)
      INTEGER incxs(4) , incys(4) , lens(4,2) , ns(4)
!     .. External Functions ..
      COMPLEX CDOTC , CDOTU
      EXTERNAL CDOTC , CDOTU
!     .. External Subroutines ..
      EXTERNAL CAXPY , CCOPY , CSWAP , CTEST
!     .. Intrinsic Functions ..
      INTRINSIC ABS , MIN
!     .. Common blocks ..
      COMMON /COMBLA/ ICAse , N , INCx , INCy , MODe , PASs
!     .. Data statements ..
      DATA ca/(0.4E0,-0.7E0)/
      DATA incxs/1 , 2 , -2 , -1/
      DATA incys/1 , -2 , 1 , -2/
      DATA lens/1 , 1 , 2 , 4 , 1 , 1 , 3 , 7/
      DATA ns/0 , 1 , 2 , 4/
      DATA cx1/(0.7E0,-0.8E0) , (-0.4E0,-0.7E0) , (-0.1E0,-0.9E0) ,     &
     &     (0.2E0,-0.8E0) , (-0.9E0,-0.4E0) , (0.1E0,0.4E0) ,           &
     &     (-0.6E0,0.6E0)/
      DATA cy1/(0.6E0,-0.6E0) , (-0.9E0,0.5E0) , (0.7E0,-0.6E0) ,       &
     &     (0.1E0,-0.5E0) , (-0.1E0,-0.2E0) , (-0.5E0,-0.3E0) ,         &
     &     (0.8E0,-0.7E0)/
      DATA ((ct8(i,j,1),i=1,7),j=1,4)/(0.6E0,-0.6E0) , (0.0E0,0.0E0) ,  &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.32E0,-1.41E0) ,          &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.32E0,-1.41E0) , (-1.55E0,0.5E0) , (0.0E0,0.0E0) ,        &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.32E0,-1.41E0) , (-1.55E0,0.5E0) ,        &
     &      (0.03E0,-0.89E0) , (-0.38E0,-0.96E0) , (0.0E0,0.0E0) ,      &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0)/
      DATA ((ct8(i,j,2),i=1,7),j=1,4)/(0.6E0,-0.6E0) , (0.0E0,0.0E0) ,  &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.32E0,-1.41E0) ,          &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (-0.07E0,-0.89E0) , (-0.9E0,0.5E0) , (0.42E0,-1.41E0) ,     &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.78E0,0.06E0) , (-0.9E0,0.5E0) ,          &
     &      (0.06E0,-0.13E0) , (0.1E0,-0.5E0) , (-0.77E0,-0.49E0) ,     &
     &      (-0.5E0,-0.3E0) , (0.52E0,-1.51E0)/
      DATA ((ct8(i,j,3),i=1,7),j=1,4)/(0.6E0,-0.6E0) , (0.0E0,0.0E0) ,  &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.32E0,-1.41E0) ,          &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (-0.07E0,-0.89E0) , (-1.18E0,-0.31E0) , (0.0E0,0.0E0) ,     &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.78E0,0.06E0) , (-1.54E0,0.97E0) ,        &
     &      (0.03E0,-0.89E0) , (-0.18E0,-1.31E0) , (0.0E0,0.0E0) ,      &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0)/
      DATA ((ct8(i,j,4),i=1,7),j=1,4)/(0.6E0,-0.6E0) , (0.0E0,0.0E0) ,  &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.32E0,-1.41E0) ,          &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.32E0,-1.41E0) , (-0.9E0,0.5E0) , (0.05E0,-0.6E0) ,       &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.32E0,-1.41E0) , (-0.9E0,0.5E0) ,         &
     &      (0.05E0,-0.6E0) , (0.1E0,-0.5E0) , (-0.77E0,-0.49E0) ,      &
     &      (-0.5E0,-0.3E0) , (0.32E0,-1.16E0)/
      DATA ct7/(0.0E0,0.0E0) , (-0.06E0,-0.90E0) , (0.65E0,-0.47E0) ,   &
     &     (-0.34E0,-1.22E0) , (0.0E0,0.0E0) , (-0.06E0,-0.90E0) ,      &
     &     (-0.59E0,-1.46E0) , (-1.04E0,-0.04E0) , (0.0E0,0.0E0) ,      &
     &     (-0.06E0,-0.90E0) , (-0.83E0,0.59E0) , (0.07E0,-0.37E0) ,    &
     &     (0.0E0,0.0E0) , (-0.06E0,-0.90E0) , (-0.76E0,-1.15E0) ,      &
     &     (-1.33E0,-1.82E0)/
      DATA ct6/(0.0E0,0.0E0) , (0.90E0,0.06E0) , (0.91E0,-0.77E0) ,     &
     &     (1.80E0,-0.10E0) , (0.0E0,0.0E0) , (0.90E0,0.06E0) ,         &
     &     (1.45E0,0.74E0) , (0.20E0,0.90E0) , (0.0E0,0.0E0) ,          &
     &     (0.90E0,0.06E0) , (-0.55E0,0.23E0) , (0.83E0,-0.39E0) ,      &
     &     (0.0E0,0.0E0) , (0.90E0,0.06E0) , (1.04E0,0.79E0) ,          &
     &     (1.95E0,1.22E0)/
      DATA ((ct10x(i,j,1),i=1,7),j=1,4)/(0.7E0,-0.8E0) , (0.0E0,0.0E0) ,&
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.6E0,-0.6E0) ,            &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.6E0,-0.6E0) , (-0.9E0,0.5E0) , (0.0E0,0.0E0) ,           &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.6E0,-0.6E0) , (-0.9E0,0.5E0) ,           &
     &      (0.7E0,-0.6E0) , (0.1E0,-0.5E0) , (0.0E0,0.0E0) ,           &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0)/
      DATA ((ct10x(i,j,2),i=1,7),j=1,4)/(0.7E0,-0.8E0) , (0.0E0,0.0E0) ,&
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.6E0,-0.6E0) ,            &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.7E0,-0.6E0) , (-0.4E0,-0.7E0) , (0.6E0,-0.6E0) ,         &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.8E0,-0.7E0) , (-0.4E0,-0.7E0) ,          &
     &      (-0.1E0,-0.2E0) , (0.2E0,-0.8E0) , (0.7E0,-0.6E0) ,         &
     &      (0.1E0,0.4E0) , (0.6E0,-0.6E0)/
      DATA ((ct10x(i,j,3),i=1,7),j=1,4)/(0.7E0,-0.8E0) , (0.0E0,0.0E0) ,&
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.6E0,-0.6E0) ,            &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (-0.9E0,0.5E0) , (-0.4E0,-0.7E0) , (0.6E0,-0.6E0) ,         &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.1E0,-0.5E0) , (-0.4E0,-0.7E0) ,          &
     &      (0.7E0,-0.6E0) , (0.2E0,-0.8E0) , (-0.9E0,0.5E0) ,          &
     &      (0.1E0,0.4E0) , (0.6E0,-0.6E0)/
      DATA ((ct10x(i,j,4),i=1,7),j=1,4)/(0.7E0,-0.8E0) , (0.0E0,0.0E0) ,&
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.6E0,-0.6E0) ,            &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.6E0,-0.6E0) , (0.7E0,-0.6E0) , (0.0E0,0.0E0) ,           &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.6E0,-0.6E0) , (0.7E0,-0.6E0) ,           &
     &      (-0.1E0,-0.2E0) , (0.8E0,-0.7E0) , (0.0E0,0.0E0) ,          &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0)/
      DATA ((ct10y(i,j,1),i=1,7),j=1,4)/(0.6E0,-0.6E0) , (0.0E0,0.0E0) ,&
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.7E0,-0.8E0) ,            &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.7E0,-0.8E0) , (-0.4E0,-0.7E0) , (0.0E0,0.0E0) ,          &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.7E0,-0.8E0) , (-0.4E0,-0.7E0) ,          &
     &      (-0.1E0,-0.9E0) , (0.2E0,-0.8E0) , (0.0E0,0.0E0) ,          &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0)/
      DATA ((ct10y(i,j,2),i=1,7),j=1,4)/(0.6E0,-0.6E0) , (0.0E0,0.0E0) ,&
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.7E0,-0.8E0) ,            &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (-0.1E0,-0.9E0) , (-0.9E0,0.5E0) , (0.7E0,-0.8E0) ,         &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (-0.6E0,0.6E0) , (-0.9E0,0.5E0) ,           &
     &      (-0.9E0,-0.4E0) , (0.1E0,-0.5E0) , (-0.1E0,-0.9E0) ,        &
     &      (-0.5E0,-0.3E0) , (0.7E0,-0.8E0)/
      DATA ((ct10y(i,j,3),i=1,7),j=1,4)/(0.6E0,-0.6E0) , (0.0E0,0.0E0) ,&
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.7E0,-0.8E0) ,            &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (-0.1E0,-0.9E0) , (0.7E0,-0.8E0) , (0.0E0,0.0E0) ,          &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (-0.6E0,0.6E0) , (-0.9E0,-0.4E0) ,          &
     &      (-0.1E0,-0.9E0) , (0.7E0,-0.8E0) , (0.0E0,0.0E0) ,          &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0)/
      DATA ((ct10y(i,j,4),i=1,7),j=1,4)/(0.6E0,-0.6E0) , (0.0E0,0.0E0) ,&
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.7E0,-0.8E0) ,            &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.7E0,-0.8E0) , (-0.9E0,0.5E0) , (-0.4E0,-0.7E0) ,         &
     &      (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,             &
     &      (0.0E0,0.0E0) , (0.7E0,-0.8E0) , (-0.9E0,0.5E0) ,           &
     &      (-0.4E0,-0.7E0) , (0.1E0,-0.5E0) , (-0.1E0,-0.9E0) ,        &
     &      (-0.5E0,-0.3E0) , (0.2E0,-0.8E0)/
      DATA csize1/(0.0E0,0.0E0) , (0.9E0,0.9E0) , (1.63E0,1.73E0) ,     &
     &     (2.90E0,2.78E0)/
      DATA csize3/(0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,       &
     &     (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0)&
     &     , (1.17E0,1.17E0) , (1.17E0,1.17E0) , (1.17E0,1.17E0) ,      &
     &     (1.17E0,1.17E0) , (1.17E0,1.17E0) , (1.17E0,1.17E0) ,        &
     &     (1.17E0,1.17E0)/
      DATA csize2/(0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) ,       &
     &     (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0) , (0.0E0,0.0E0)&
     &     , (1.54E0,1.54E0) , (1.54E0,1.54E0) , (1.54E0,1.54E0) ,      &
     &     (1.54E0,1.54E0) , (1.54E0,1.54E0) , (1.54E0,1.54E0) ,        &
     &     (1.54E0,1.54E0)/
!     .. Executable Statements ..
      DO ki = 1 , 4
         INCx = incxs(ki)
         INCy = incys(ki)
         mx = ABS(INCx)
         my = ABS(INCy)
!
         DO kn = 1 , 4
            N = ns(kn)
            ksize = MIN(2,kn)
            lenx = lens(kn,mx)
            leny = lens(kn,my)
!           .. initialize all argument arrays ..
            DO i = 1 , 7
               cx(i) = cx1(i)
               cy(i) = cy1(i)
            ENDDO
            IF ( ICAse==1 ) THEN
!              .. CDOTC ..
               cdot(1) = CDOTC(N,cx,INCx,cy,INCy)
               CALL CTEST(1,cdot,ct6(kn,ki),csize1(kn),Sfac)
            ELSEIF ( ICAse==2 ) THEN
!              .. CDOTU ..
               cdot(1) = CDOTU(N,cx,INCx,cy,INCy)
               CALL CTEST(1,cdot,ct7(kn,ki),csize1(kn),Sfac)
            ELSEIF ( ICAse==3 ) THEN
!              .. CAXPY ..
               CALL CAXPY(N,ca,cx,INCx,cy,INCy)
               CALL CTEST(leny,cy,ct8(1,kn,ki),csize2(1,ksize),Sfac)
            ELSEIF ( ICAse==4 ) THEN
!              .. CCOPY ..
               CALL CCOPY(N,cx,INCx,cy,INCy)
               CALL CTEST(leny,cy,ct10y(1,kn,ki),csize3,1.0E0)
               IF ( ki==1 ) THEN
                  cx0(1) = (42.0E0,43.0E0)
                  cy0(1) = (44.0E0,45.0E0)
                  IF ( N==0 ) THEN
                     cty0(1) = cy0(1)
                  ELSE
                     cty0(1) = cx0(1)
                  ENDIF
                  lincx = INCx
                  INCx = 0
                  lincy = INCy
                  INCy = 0
                  CALL CCOPY(N,cx0,INCx,cy0,INCy)
                  CALL CTEST(1,cy0,cty0,csize3,1.0E0)
                  INCx = lincx
                  INCy = lincy
               ENDIF
            ELSEIF ( ICAse==5 ) THEN
!              .. CSWAP ..
               CALL CSWAP(N,cx,INCx,cy,INCy)
               CALL CTEST(lenx,cx,ct10x(1,kn,ki),csize3,1.0E0)
               CALL CTEST(leny,cy,ct10y(1,kn,ki),csize3,1.0E0)
            ELSE
               WRITE (NOUT,*) ' Shouldn''t be here in CHECK2'
               STOP
            ENDIF
!
         ENDDO
      ENDDO
      END SUBROUTINE CHECK2
!*==stest.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      SUBROUTINE STEST(Len,Scomp,Strue,Ssize,Sfac)
      IMPLICIT NONE
!*--STEST591
!     ********************************* STEST **************************
!
!     THIS SUBR COMPARES ARRAYS  SCOMP() AND STRUE() OF LENGTH LEN TO
!     SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE
!     NEGLIGIBLE.
!
!     C. L. LAWSON, JPL, 1974 DEC 10
!
!     .. Parameters ..
      INTEGER NOUT
      REAL ZERO
      PARAMETER (NOUT=6,ZERO=0.0E0)
!     .. Scalar Arguments ..
      REAL Sfac
      INTEGER Len
!     .. Array Arguments ..
      REAL Scomp(Len) , Ssize(Len) , Strue(Len)
!     .. Scalars in Common ..
      INTEGER ICAse , INCx , INCy , MODe , N
      LOGICAL PASs
!     .. Local Scalars ..
      REAL sd
      INTEGER i
!     .. External Functions ..
      REAL SDIFF
      EXTERNAL SDIFF
!     .. Intrinsic Functions ..
      INTRINSIC ABS
!     .. Common blocks ..
      COMMON /COMBLA/ ICAse , N , INCx , INCy , MODe , PASs
!     .. Executable Statements ..
!
      DO i = 1 , Len
         sd = Scomp(i) - Strue(i)
         IF ( ABS(Sfac*sd)>ABS(Ssize(i))*EPSILON(ZERO) ) THEN
!
!                             HERE    SCOMP(I) IS NOT CLOSE TO STRUE(I).
!
            IF ( PASs ) THEN
!                             PRINT FAIL MESSAGE AND HEADER.
               PASs = .FALSE.
               WRITE (NOUT,99001)
!
99001          FORMAT ('                                       FAIL')
               WRITE (NOUT,99002)
99002          FORMAT (/                                                &
     &          ' CASE  N INCX INCY MODE  I                            '&
     &          ,                                                       &
     &        ' COMP(I)                             TRUE(I)  DIFFERENCE'&
     &        ,'     SIZE(I)',/1X)
            ENDIF
            WRITE (NOUT,99003) ICAse , N , INCx , INCy , MODe , i ,     &
     &                         Scomp(i) , Strue(i) , sd , Ssize(i)
99003       FORMAT (1X,I4,I3,3I5,I3,2E36.8,2E12.4)
         ENDIF
      ENDDO
      RETURN
      END SUBROUTINE STEST
!*==stest1.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      SUBROUTINE STEST1(Scomp1,Strue1,Ssize,Sfac)
      IMPLICIT NONE
!*--STEST1653
!     ************************* STEST1 *****************************
!
!     THIS IS AN INTERFACE SUBROUTINE TO ACCOMMODATE THE FORTRAN
!     REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE
!     ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT.
!
!     C.L. LAWSON, JPL, 1978 DEC 6
!
!     .. Scalar Arguments ..
      REAL Scomp1 , Sfac , Strue1
!     .. Array Arguments ..
      REAL Ssize(*)
!     .. Local Arrays ..
      REAL scomp(1) , strue(1)
!     .. External Subroutines ..
      EXTERNAL STEST
!     .. Executable Statements ..
!
      scomp(1) = Scomp1
      strue(1) = Strue1
      CALL STEST(1,scomp,strue,Ssize,Sfac)
!
      END SUBROUTINE STEST1
!*==sdiff.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      REAL FUNCTION SDIFF(Sa,Sb)
      IMPLICIT NONE
!*--SDIFF680
!     ********************************* SDIFF **************************
!     COMPUTES DIFFERENCE OF TWO NUMBERS.  C. L. LAWSON, JPL 1974 FEB 15
!
!     .. Scalar Arguments ..
      REAL Sa , Sb
!     .. Executable Statements ..
      SDIFF = Sa - Sb
      END FUNCTION SDIFF
!*==ctest.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      SUBROUTINE CTEST(Len,Ccomp,Ctrue,Csize,Sfac)
      IMPLICIT NONE
!*--CTEST692
!     **************************** CTEST *****************************
!
!     C.L. LAWSON, JPL, 1978 DEC 6
!
!     .. Scalar Arguments ..
      REAL Sfac
      INTEGER Len
!     .. Array Arguments ..
      COMPLEX Ccomp(Len) , Csize(Len) , Ctrue(Len)
!     .. Local Scalars ..
      INTEGER i
!     .. Local Arrays ..
      REAL scomp(20) , ssize(20) , strue(20)
!     .. External Subroutines ..
      EXTERNAL STEST
!     .. Intrinsic Functions ..
      INTRINSIC AIMAG , REAL
!     .. Executable Statements ..
      DO i = 1 , Len
         scomp(2*i-1) = REAL(Ccomp(i))
         scomp(2*i) = AIMAG(Ccomp(i))
         strue(2*i-1) = REAL(Ctrue(i))
         strue(2*i) = AIMAG(Ctrue(i))
         ssize(2*i-1) = REAL(Csize(i))
         ssize(2*i) = AIMAG(Csize(i))
      ENDDO
!
      CALL STEST(2*Len,scomp,strue,ssize,Sfac)
      END SUBROUTINE CTEST
!*==itest1.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      SUBROUTINE ITEST1(Icomp,Itrue)
      IMPLICIT NONE
!*--ITEST1725
!     ********************************* ITEST1 *************************
!
!     THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR
!     EQUALITY.
!     C. L. LAWSON, JPL, 1974 DEC 10
!
!     .. Parameters ..
      INTEGER NOUT
      PARAMETER (NOUT=6)
!     .. Scalar Arguments ..
      INTEGER Icomp , Itrue
!     .. Scalars in Common ..
      INTEGER ICAse , INCx , INCy , MODe , N
      LOGICAL PASs
!     .. Local Scalars ..
      INTEGER id
!     .. Common blocks ..
      COMMON /COMBLA/ ICAse , N , INCx , INCy , MODe , PASs
!     .. Executable Statements ..
      IF ( Icomp/=Itrue ) THEN
!
!                            HERE ICOMP IS NOT EQUAL TO ITRUE.
!
         IF ( PASs ) THEN
!                             PRINT FAIL MESSAGE AND HEADER.
            PASs = .FALSE.
            WRITE (NOUT,99001)
!
99001       FORMAT ('                                       FAIL')
            WRITE (NOUT,99002)
99002       FORMAT (/                                                   &
     &          ' CASE  N INCX INCY MODE                               '&
     &          ,                                                       &
     &        ' COMP                                TRUE     DIFFERENCE'&
     &        ,/1X)
         ENDIF
         id = Icomp - Itrue
         WRITE (NOUT,99003) ICAse , N , INCx , INCy , MODe , Icomp ,    &
     &                      Itrue , id
99003    FORMAT (1X,I4,I3,3I5,2I36,I12)
      ENDIF
      RETURN
      END SUBROUTINE ITEST1


program uninitialized_variable
    implicit none
    integer, parameter :: n = 5
    integer :: i
    do i = 1, n
        print '(A, F10.3)', 'sum = ', compute_sum(n)
    end do

contains

    function compute_sum(n) result(r)
        implicit none
        integer, intent(in) :: n
        real :: r, sum, x
        integer :: i
        do i = 1, n
            call random_number(x)
            sum = sum + x
        end do
        r = sum/n
    end function compute_sum

end program uninitialized_variable


MODULE kind

  IMPLICIT NONE

  PRIVATE

  PUBLIC :: i4, i8, sp, dp

  INTEGER, PARAMETER :: i4 = SELECTED_INT_KIND(9)
  INTEGER, PARAMETER :: i8 = SELECTED_INT_KIND(14)

  INTEGER, PARAMETER :: sp = SELECTED_REAL_KIND(6,37)
  INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(12,307)

END MODULE kind


submodule(euler_interface_m) euler_prob_0004_m
    implicit none

contains

    module character(len=20) function euler0004()
        write (euler0004, "(i20)") answer(999)
    end function euler0004

    pure function answer(n) result(ret)
        integer, intent(in) :: n
        integer :: i, j, ret

        ret = 0
        do i = 100, n
            do j = 100, n
                if (is_palindromic(i*j) .and. i*j > ret) ret = i*j
            end do
        end do
    end function answer

end submodule euler_prob_0004_m


C++***************************************************************
C	Program ISOPHOTE
C To draw isophotes
C
C	IMAGE(NX,NY) Input image to be drawn
C	 (REAL*4)
C	AUX(I) : INTENSITE DU NIVEAU I (REEL)
C	NIV(I) : INTENSITE DU NIVEAU I (ENTIER)
C	ID(5) : MAILLE ELEMENTAIRE POUR LE TRACE DES ISOPHOTES
C	JK(4) : MAILLE ELEM. DE TEST ( > OU < A L'ISOPHOTE)
C JLP Version of 05-06-91
C--****************************************************************
	PROGRAM ISOPHOTE
        PARAMETER (MAX_LEVELS=100)
	INTEGER*4 PNTR_IN,MADRID(1)
	REAL*4 NIV(MAX_LEVELS),XOUT,YOUT
	REAL*4 XCENTER,YCENTER,DIAMETER,SKY,SIGMA
        REAL*4 MIN1,MAX1,MEAN1,MEAN2,SIGMA1,SIGMA2
        REAL*4 NE_LENGTH,X_NE,Y_NE,NE_ANGLE
        REAL*4 START1,STEP1,BACK1,EPSILON1
	INTEGER*4 NLEV1,NOUT,NE_FLAG
        INTEGER*4 IXSTART,IXEND,IYSTART,IYEND
        INTEGER*4 IXMIN,IXMAX,IYMIN,IYMAX
	LOGICAL*4 INTERAC,DEFAULT_VALUES,DRAW_CIRCLE,DRAW_SCALE,NORTH_EAST
        INTEGER*4 TICKS_IN,BOX_NUMBERS
	CHARACTER INTERACDEV*32,PLOTDEV*32,HARDCOPYDEV*32
        CHARACTER BUFFER*80,BUFFER_LEVELS*80
	CHARACTER NAME*40,COMMENTS*80,ANS*1,SCALE_LABEL*40
	CHARACTER CHAR1*30,CHAR2*30,TITLE*40
	COMMON/VMR/MADRID

C Output points :
	COMMON/STR_OUTPUT/XOUT(200),YOUT(200),NOUT

10	FORMAT(A)
	IOPT=0
        TICKS_IN = 1
        BOX_NUMBERS = 1
	DRAW_CIRCLE=.FALSE.
	DRAW_SCALE=.FALSE.
        NORTH_EAST=.FALSE.
	OPEN(1,FILE='isophote.log',STATUS='unknown',
     1	ACCESS='SEQUENTIAL')

C Inquire the format of the files:
	CALL JLP_BEGIN
	CALL JLP_INQUIFMT

        PRINT *,84
84	FORMAT(' Program ISOPHOTE Version 05-06-91')

	PRINT *,' Use defaults values (full image, step=1, etc...)? [Y]'
	READ(5,10)ANS
	DEFAULT_VALUES=(ANS.NE.'N'.AND.ANS.NE.'n')

C Inquire the device :
	WRITE(6,32)
32      FORMAT(' Interactive graphic output device',
     1         '(&xterm, &tektronix, &square, &none ...)?')
	READ(5,10) INTERACDEV
C Shift of one to allow standard denomination
C like &tektronix, $TEKTRO, etc
	INTERACDEV=INTERACDEV(2:)
	INTERAC=(INTERACDEV(1:1).EQ.'x'.OR.INTERACDEV(1:1).EQ.'t')

C Input of the parameters for drawing the levels
	PRINT *,' Input image ?'
	READ(5,10) NAME
	CALL JLP_VM_READIMAG(PNTR_IN,NX,NY,NAME,COMMENTS)
	WRITE (1,104)NAME
104	FORMAT(/,2X,' Input file: ',A)

C Batch mode:
	IF(DEFAULT_VALUES)THEN
 	  IXSTART=1
	  IXEND=NX
	  ISTEPX=1
	  IYSTART=1
	  IYEND=NY
	  ISTEPY=1

        ELSE
C Boundaries :
          CALL INPUT_BOUNDARIES(IXSTART,IXEND,ISTEPX,IYSTART,IYEND,ISTEPY)
        ENDIF

C Input of the levels for the first time:
        CALL JLP_AUTO_SCALE(MADRID(PNTR_IN),NX,NY,NX,MIN1,MAX1,
     1  MEAN1,MEAN2,SIGMA1,SIGMA2,IXMIN,IYMIN,IXMAX,IYMAX)
        CALL AUTO_SKY(MADRID(PNTR_IN),NX,NY,NX,SKY,SIGMA)

C Computing automatic (log) scale:

C Epsilon is the smallest value for log computation:
        EPSILON1=SIGMA/1.E+9
C Default is log scale:
        BACK1=SKY-3.*SIGMA
C Minimum is mean (after 3-sigma rejection) plus 1.5 sigma:
        WORK=MEAN2+1.5*SIGMA2
C Conversion to log scale:
        WORK=MAX(EPSILON1,WORK-BACK1)
        START1=LOG10(WORK)
C Maximum is actual maximum value (but will not be reached):
C We will stop at one level below...
        WORK=MAX(EPSILON1,MAX1-BACK1)
C Conversion to log scale:
        WORK=LOG10(WORK)
        NLEV1=10
        STEP1=(WORK-START1)/FLOAT(NLEV1-2)
        STEP1=MAX(STEP1,EPSILON1)
        WRITE(BUFFER_LEVELS,23) START1,NLEV1,STEP1,BACK1
23      FORMAT(1PG10.3,':',I4,':',1PG10.3,':',1PG10.3)
        WRITE(6,28)
28      FORMAT('Computing automatic (log) scale')
        CALL INPUT_LEVELS(NIV,NNIV,MAX_LEVELS,BUFFER_LEVELS,EPSILON1)

501     IF(DEFAULT_VALUES.OR.INTERAC)THEN
	  CHAR1=' '
	  CHAR2=' '
	  TITLE(1:40)=NAME(1:14)//BUFFER(1:25)
	ELSE
600	 PRINT *,' Enter the title :'
	 TITLE=' '
	 READ(5,10) TITLE(2:40)
	 PRINT *,' Enter X label :'
	 CHAR1=' '
	 READ(5,10) CHAR1(2:30)
	 PRINT *,' Enter Y label :'
	 CHAR2=' '
	 READ(5,10) CHAR2(2:30)
	ENDIF

C Beginning:
500     CONTINUE
        IF(IOPT.NE.3)THEN
           PLOTDEV=INTERACDEV
        ELSE
           PLOTDEV=HARDCOPYDEV
        ENDIF
C Debug
        CALL ISOCONTOURS(MADRID(PNTR_IN),NX,NY,NX,IXSTART,
     1    IXEND,ISTEPX,IYSTART,IYEND,ISTEPY,NIV,NNIV,
     1    CHAR1,CHAR2,TITLE,
     1	  PLOTDEV,INTERAC,TICKS_IN,BOX_NUMBERS,NAME,COMMENTS)
C Circle:
        IF(DRAW_CIRCLE)THEN
          WRITE(1,44) XCENTER,YCENTER,DIAMETER
44        FORMAT(' Circle at X,Y = ',2(G10.3,1X),
     1             ' Diameter: ',G10.3)
	  CALL STR_CIRCLE(XCENTER,YCENTER,DIAMETER)
	  CALL JLP_GFLUSH
        ENDIF
C Scale
        IF(DRAW_SCALE)THEN
	  CALL STR_SCALE(X_SCALE,Y_SCALE,SCALE_LENGTH,SCALE_LABEL)
	  CALL JLP_GFLUSH
        ENDIF

C North East direction:
        IF(NORTH_EAST)THEN
	  CALL STR_NORTH_EAST(X_NE,Y_NE,NE_LENGTH,NE_ANGLE,NE_FLAG)
	  CALL JLP_GFLUSH
        ENDIF

C Closes plot:
        CALL STR_PLOT(0.,0.,999)
C Print output points (cursor)
	IF(NOUT.GT.0)THEN
	  DO I=1,NOUT
	    CALL GETPIXEL(MADRID(PNTR_IN),NX,NY,NX,
     1      XOUT(I),YOUT(I),IX,IY,XVALUE)
            IF(XVALUE.GT.0.)THEN
               WORK = LOG10(XVALUE)
            ELSE
               WORK = -100.
            ENDIF
	    PRINT *,' Point #',I,IX,IY,' value: ',XVALUE,' log10: ',WORK
	  END DO
	ENDIF
C---------------------------------------------------------
C Entering next option
	PRINT 310
310	FORMAT(' Menu :',/,
     1	' 1: Change the levels',/,
     1	' 2: Change the limits for the display',/,
     1	' 3: Store the graph (plot.plt)',/,
     1	' 4: Change the image only',/,
     1	' 5: Change the title and labels',/,
     1	' 6: Draw a circle',/,
     1	' 7: Erase the circle',/,
     1	' 8: Draw a scale bar',/,
     1	' 9: Erase the scale bar',/,
     1	' 10: Toggle for axis numbers: ON/OFF',/,
     1	' 11: Toggle for axis ticks: IN/OUT',/,
     1	' 12: Draw North-East directions',/,
     1	' 13: Erase North_East directions',/,
     1	' 20: Exit',/,
     1	' Enter the option you want : ')
	READ(5,*,ERR=999) IOPT
C**********************************************************
C Change the levels:
	IF(IOPT.EQ.1) THEN
          CALL INPUT_LEVELS(NIV,NNIV,MAX_LEVELS,BUFFER_LEVELS,EPSILON1)
C Then plots the graph with new levels:
          GOTO 500
        ENDIF
C**********************************************************
C Change boundaries :
	IF(IOPT.EQ.2) THEN
          CALL INPUT_BOUNDARIES(IXSTART,IXEND,ISTEPX,IYSTART,IYEND,ISTEPY)
	  GOTO 500
        ENDIF
C**********************************************************
C Change output device :
	IF(IOPT.EQ.3) THEN
	  WRITE(6,33)
33        FORMAT(' Hardcopy graphic device',
     1            ' (&postscript, &landscape, &square ...)?')
	  READ(5,10) HARDCOPYDEV
C Shift of one to allow standard denomination like &tektronix, $TEKTRO, etc
	  HARDCOPYDEV=HARDCOPYDEV(2:)
	  INTERAC=(HARDCOPYDEV(1:1).EQ.'x'.OR.HARDCOPYDEV(1:1).EQ.'t')
	  GO TO 500
	ENDIF
C**********************************************************
C Change input image:
	IF(IOPT.EQ.4)THEN
           PRINT *,' INPUT FILE ?'
	   READ(5,10) NAME
	   CALL JLP_VM_READIMAG(PNTR_IN,NX,NY,NAME,COMMENTS)
	   WRITE (1,104)NAME
          IF(DEFAULT_VALUES.OR.INTERAC) TITLE(1:40)=NAME(1:14)//BUFFER(1:25)
           GOTO 500
        ENDIF
C**********************************************************
	IF(IOPT.EQ.5)GO TO 600
C**********************************************************
C Draw a circle:
	IF(IOPT.EQ.6)THEN
	  WRITE(6,*)' Xcenter, Ycenter, Diameter?'
	  READ(5,*) XCENTER,YCENTER,DIAMETER
	  DRAW_CIRCLE=.TRUE.
	  GOTO 500
	ENDIF
C**********************************************************
C Erase the circle:
	IF(IOPT.EQ.7)THEN
	  DRAW_CIRCLE=.FALSE.
	  GOTO 500
	ENDIF
C**********************************************************
C Draw a scale bar:
	IF(IOPT.EQ.8)THEN
	  WRITE(6,*)' The scale will be an horizontal bar'
	  WRITE(6,*)' Length in pixel, X and Y start position (user coord.):'
	  READ(5,*) SCALE_LENGTH,X_SCALE,Y_SCALE
	  WRITE(6,*)' Label to write on top (centered):'
	  READ(5,10) SCALE_LABEL
	  DRAW_SCALE=.TRUE.
	  GOTO 500
	ENDIF
C**********************************************************
C Erase the scale bar:
	IF(IOPT.EQ.9)THEN
	  DRAW_SCALE=.FALSE.
	  GOTO 500
	ENDIF
C**********************************************************
C Toggle to active or desactive axis numbers:
	IF(IOPT.EQ.10)THEN
          BOX_NUMBERS = 1 - BOX_NUMBERS
          IF(BOX_NUMBERS.EQ.1)THEN
            WRITE(6,*)'Axes numbered'
          ELSE
            WRITE(6,*)'Axes without numbers'
          ENDIF
	  GOTO 500
	ENDIF
C**********************************************************
C Toggle for ticks in or out:
	IF(IOPT.EQ.11)THEN
          TICKS_IN = 1 - TICKS_IN
          IF(TICKS_IN.EQ.1)THEN
            WRITE(6,*)'Ticks in'
          ELSE
            WRITE(6,*)'Ticks out'
          ENDIF
	  GOTO 500
	ENDIF

C**********************************************************
C Draw North-East directions:
	IF(IOPT.EQ.12)THEN
	  WRITE(6,*)' North-East directions: '
	  WRITE(6,*)' Bar length in pixel, X and Y start position (user coord.):'
	  READ(5,*) NE_LENGTH,X_NE,Y_NE
	  WRITE(6,21)
21        FORMAT(' Position angle for the North ',/,
     1    '(Convention is OX axis: 0., OY axis: 90., -OX: 180., -OY: 270.)',/,
     1    ' and direction flag (1 if East angle > North angle, -1 otherwise):')
	  READ(5,*) NE_ANGLE,NE_FLAG
	  NORTH_EAST=.TRUE.
	  GOTO 500
	ENDIF
C**********************************************************
C Erase the scale bar:
	IF(IOPT.EQ.13)THEN
	  NORTH_EAST=.FALSE.
	  GOTO 500
	ENDIF

C
999	PRINT *,' Logfile in "isophote.log"'
	CLOSE(1)
	CALL JLP_END
	STOP
	END
C************************************************************
        SUBROUTINE GETPIXEL(ARRAY,NX,NY,IDIM,X,Y,IX,IY,XVALUE)
	REAL*4 ARRAY(IDIM,*)
        REAL*4 X,Y,XVALUE
        INTEGER*4 NX,NY,IX,IY

	IX=NINT(X)
	IX=MIN(NX,IX)
	IX=MAX(1,IX)

	IY=NINT(Y)
	IY=MIN(NY,IY)
	IY=MAX(1,IY)

	XVALUE=ARRAY(IX,IY)

        RETURN
	END
C********************************************************************
C
C EPSILON1 is the smallest value for log computation
C********************************************************************
        SUBROUTINE INPUT_LEVELS(NIV,NNIV,NMAX,OLD_BUFFER,EPSILON1)
        REAL*4 NIV(*),BACKGROUND,EPSILON1,WORK
        INTEGER*4 NNIV,NMAX
        INTEGER*4 I1,I2,K1,K2
        CHARACTER BUFFER*80,WORD*80,OLD_BUFFER*80

10      FORMAT(A)

        IF(OLD_BUFFER(1:2).NE.'  ')THEN
          PRINT *,' Current levels are: '
          WRITE(6,10) OLD_BUFFER
        ENDIF
400     WRITE(6,401)
401	FORMAT(' Three possibilities: discrete levels, log or linear series',/,
     1   ' Enter the discrete levels separated by commas: (Ex: 1.E-3,2.E-2)'
     1   ,/,' Or start/nber_of_steps/step  (for linear series):',
     1   ' (Ex: 1.0/20/0.1)',/,
     1   ' Or start:nber_of_steps:step:sky_back (for log series):',
     1   ' (Ex: 1.0:10:0.1:48.7)  (Type "CR" to keep current levels)')
	READ(5,10) BUFFER
        IF(BUFFER.EQ.'')BUFFER=OLD_BUFFER

C Decoding BUFFER now:
	K1=INDEX(BUFFER(1:80),'/')
	K2=INDEX(BUFFER(1:80),':')
C Linear series:
        IF(K1.GT.1)THEN
          CALL INPUT3(NIV,NNIV,NMAX,BUFFER,'/',3,ISTATUS)
          IF(ISTATUS.NE.0) GOTO 400
          STEP=NIV(3)
          DO I=2,NNIV
            NIV(I)=NIV(1)+FLOAT(I-1)*STEP
            PRINT *,' I, NIV ',I,NIV(I)
          END DO
C Log series:
        ELSEIF(K2.GT.1)THEN
          CALL INPUT3(NIV,NNIV,NMAX,BUFFER,':',4,ISTATUS)
          IF(ISTATUS.NE.0) GOTO 400
          STEP=NIV(3)
          BACKGROUND=NIV(4)
          DO I=2,NNIV
            NIV(I)=NIV(1)+FLOAT(I-1)*STEP
          END DO
C Transformation:
          DO I=1,NNIV
C            WORK=MAX(EPSILON1,NIV(I)-BACKGROUND)
            NIV(I)=BACKGROUND + 10**NIV(I)
            PRINT *,' I, NIV, LOG10(NIV-BACK)',I,NIV(I),LOG10(NIV(I)-BACKGROUND)
          END DO
C Discrete levels:
        ELSE
	 NNIV=0
	 I1=1
408	 I2=80
	 K1=INDEX(BUFFER(I1:80),',')
	 IF(K1.GT.1) I2=I1-2+K1
C	 PRINT *,' I1, I2',I1,I2
	   IF(I1.LE.I2)THEN
	     WORD=BUFFER(I1:I2)
	     READ(WORD,*,ERR=413) NIV(NNIV+1)
	     NNIV=NNIV+1
	     WRITE(1,40) NNIV,NIV(NNIV)
40           FORMAT(' Level #',I3,' value: ',G12.5)
C	     PRINT *,' NIV(I)',NIV(NNIV+1)
	     I1=I2+2
	     GOTO 408
	   ENDIF
C End of cases discrete/linear
        ENDIF

C Save current buffer (to make change easier for the user):
413	 OLD_BUFFER=BUFFER
         RETURN
         END
C******************************************************************
         SUBROUTINE INPUT_BOUNDARIES(IXSTART,IXEND,ISTEPX,IYSTART,IYEND,ISTEPY)
         INTEGER*4 IXSTART,IXEND,ISTEPX,IYSTART,IYEND,ISTEPY
         INTEGER*4 NX1,NY1

300      WRITE(6,3)
3	  FORMAT(' Enter first pixel, last pixel and step (integers):')
	  READ(5,*) IXSTART,IXEND,ISTEPX
	  IF(IXSTART.GE.IXEND.OR.ISTEPX.LE.0) GO TO 300

400	 WRITE(6,4)
4	  FORMAT(' Enter first, last line and step (integers):')
	  READ(5,*) IYSTART,IYEND,ISTEPY
	  IF(IYSTART.GE.IYEND.OR.ISTEPY.LE.0) GO TO 400

	 WRITE(1,41) IXSTART,IXEND,ISTEPX,IYSTART,IYEND,ISTEPY
41       FORMAT(' Start, end, step in X: ',3(I5,1X),/,
     1   ' Start, end, step in Y: ',3(I5,1X))

         RETURN
         END
C************************************************************
C
C To input the parameters separated by '/' or '\'
C
C Output in NIV(1),NIV(2),NIV(3)
C************************************************************
        SUBROUTINE INPUT3(NIV,NNIV,NMAX,BUFFER,SYMBOL,NVAL,ISTATUS)
        REAL*4 NIV(*)
        INTEGER*4 NNIV,NMAX,NVAL,IVAL
        INTEGER*4 I1,I2,K1,K2
        CHARACTER BUFFER*80,WORD*80,SYMBOL*1

        ISTATUS=0
	IVAL=0
	I1=1
C Main loop:
308	 I2=80
	 K1=INDEX(BUFFER(I1:80),SYMBOL)
	 IF(K1.GT.1) I2=I1-2+K1
C	 PRINT *,' I1, I2',I1,I2
	 IF(I1.LE.I2)THEN
	   WORD=BUFFER(I1:I2)
	   READ(WORD,*,ERR=309) NIV(IVAL+1)
	   IVAL=IVAL+1
	   WRITE(1,441) IVAL,NIV(IVAL)
441         FORMAT(' INPUT3/Input #',I3,' value: ',G12.5)
	   I1=I2+2
	   GOTO 308
	 ENDIF
C
C Should be:  NNIV=3 or 4 and NIV(1)=start, NIV(2)=nber of steps, NIV(3)=step
C and background (if log)
         IF(IVAL.NE.NVAL)THEN
309         PRINT *,' Syntax error: try again'
            PRINT *,' NIV(1), step, number of levels ',NIV(1),NIV(3),NIV(2)
            IF(SYMBOL(1:1).EQ.':')WRITE(6,34) NIV(4)
            ISTATUS=-1
            RETURN
         ENDIF
C
         NNIV=INT(NIV(2))
         PRINT *,' NIV(1), step, number of levels ',NIV(1),NIV(3),NIV(2)
         IF(NNIV.GT.NMAX)THEN
             NNIV=NMAX
             PRINT *,' INPUT3/Error, only ',NMAX,' levels allowed'
             PRINT *,' (whereas required number of levels is:',NNIV,')'
             ISTATUS=-1
         ENDIF

         IF(SYMBOL(1:1).EQ.':')WRITE(6,34) NIV(4)
34       FORMAT(' Sky background to be subtracted to input',
     1           ' data (for display only):',G12.5)

         RETURN
         END
C*****************************************************************
	include 'jlpsub:isophote_set.for'
	include 'jlpsub:str.for'
        include 'jlpsub:jlp_auto_scale.for'
        include 'jlpsub:auto_sky.for'


C Copyright(c) 1997, Space Science and Engineering Center, UW-Madison
C Refer to "McIDAS Software Acquisition and Distribution Policies"
C in the file  mcidas/data/license.txt

      SUBROUTINE ASSPL2(N,X,Y,C)
C *** $Id: asspl2.f,v 1.6 1997/10/10 20:16:37 dglo Exp $ ***
CNP   ASSPL2
C * CALLED BY 'SPLINE'
C $ CALL ASSPL2(N, X, Y, C)  (DAS)
C $ CUBIC SPLINE GENERATOR.  SECOND DERIV. NOT CONTINUOUS.  THE DEGREES
C $   OF FREEDOM GAINED ARE USED IN AN ATTEMPT TO AVOID  OSCILLATIONS.
C $   FIT TO THE POINTS (X(I),Y(I)) I=1,...,N .
C $ INPUT:
C $   N = (I) THE NUMBER OF DATA POINTS
C $   X = (R) ARRAY OF THE ABSCISSA OF POINTS
C $   Y = (R) ARRAY OF THE ORDINATE OF POINTS
C $ OUTPUT:
C $   C = (R) ARRAY OF CUBIC SPLINE COEFFICIENTS
C $$ ASSPL2 = COMPUTATION
      DIMENSION X(N),Y(N),C(4,N)
      M=N-1
      DO 150 I=1,M
      IF(I .EQ. 1) GO TO 110
      T=(Y(I+1)-Y(I-1))/(X(I+1)-X(I-1))
      GO TO 120
  110 W=(Y(2)+Y(3))/2.0
      Z=(X(2)+X(3))/2.0
      T=(W-Y(1))/(Z-X(1))
      T=2.0*(Y(2)-Y(1))/(X(2)-X(1))-T
  120 IF(I .EQ. M) GO TO 130
      S=(Y(I+2)-Y(I))/(X(I+2)-X(I))
      GO TO 140
  130 W=(Y(N-1)+Y(N-2))/2.0
      Z=(X(N-1)+X(N-2))/2.0
      S=(Y(N)-W)/(X(N)-Z)
      S=2.0*(Y(N)-Y(N-1))/(X(N)-X(N-1))-S
  140 U=Y(I+1)
      V=Y(I)
      W=(X(I+1)+X(I))/2.0
      Z=(X(I+1)-X(I))/2.0
      ZS=Z*Z
      ZQ=Z*ZS
      WS=W*W
      WQ=W*WS
      AA=.5*(U+V)-.25*Z*(S-T)
      BA=.75*(U-V)/Z-.25*(S+T)
      CA=.25*(S-T)/Z
      DA=.25*(S+T)/ZS-.25*(U-V)/ZQ
      C(1,I)=AA-BA*W+CA*WS-DA*WQ
      C(2,I)=BA-2.0*CA*W+3.0*DA*WS
      C(3,I)=CA-3.0*DA*W
      C(4,I)=DA
  150 CONTINUE
      DO 44 J=1,4
      C(J,N)=C(J,N-1)
44    CONTINUE
      RETURN
      END
      FUNCTION FVAL(N,U,X,C)
C $ FVAL(N, U, X, C)  (WBH)
C $ EVALUATES THE CUBIC SPLINE COEFFICIENTS AT A POINT
C $ N = (I) INPUT  NUMBER OF DATA POINTS
C $ U = (R) INPUT POINT TO EVALUATE
C $ X = (R) INPUT  ARRAY OF ABSCISSA OF POINTS
C $ C = (R) OUTPUT  ARRAY OF CUBIC SPINE COEFFICIENT
C $$ FVAL = COMPUTATION
      REAL U,X(N),C(4,N)
      DATA I /1/
      IF (I .GE. N) I=1
      IF (U .LT. X(I))GO TO 10
      IF (U .LE. X(I+1))GO TO 30
   10 I= 1
      J= N + 1
   20 K= (I+J)/2
      IF (U .LT. X(K)) J=K
      IF (U .GE. X(K)) I=K
      IF (J .GT. I+1)GO TO 20
   30 CONTINUE
      FVAL=C(1,I)+U*(C(2,I)+U*(C(3,I)+U*C(4,I)))
      RETURN
      END


module da_verif_tools

   implicit none

   ! Define some private constants

   real, private, parameter    :: pi = 3.1415926
   real, private, parameter    :: deg_per_rad = 180.0/pi
   real, private, parameter    :: rad_per_deg = pi / 180.0
   logical, private, parameter :: print_detail_map = .false.

   integer, private, parameter :: stdout = 6

   ! Mean Earth Radius in m.  The value below is consistent
   ! with NCEP's routines and grids.
   ! real, public , parameter    :: earth_radius_m = 6371200.0 ! from Brent
   real, public , parameter    :: earth_radius_m = 6370000.0
   real, public , parameter    :: radians_per_degree = pi / 180.0

   ! Define public parameters

   ! Projection codes for proj_info structure:
   integer, public, parameter  :: PROJ_LATLON = 0
   integer, public, parameter  :: PROJ_MERC = 1
   integer, public, parameter  :: PROJ_LC = 3
   integer, public, parameter  :: PROJ_PS = 5

  ! Define data structures to define various projections

   type proj_info
      integer          :: code     ! integer code for projection type
      real             :: lat1     ! SW latitude (1,1) in degrees (-90->90N)
      real             :: lon1     ! SW longitude (1,1) in degrees (-180->180E)
      real             :: dx       ! Grid spacing in meters at truelats, used
                                   ! only for ps, lc, and merc projections
      real             :: dlat     ! Lat increment for lat/lon grids
      real             :: dlon     ! Lon increment for lat/lon grids
      real             :: stdlon   ! Longitude parallel to y-axis (-180->180E)
      real             :: truelat1 ! First true latitude (all projections)
      real             :: truelat2 ! Second true lat (LC only)
      real             :: hemi     ! 1 for NH, -1 for SH
      real             :: cone     ! Cone factor for LC projections
      real             :: polei    ! Computed i-location of pole point
      real             :: polej    ! Computed j-location of pole point
      real             :: rsw      ! Computed radius to SW corner
      real             :: rebydx   ! Earth radius divided by dx
      real             :: knowni   ! X-location of known lat/lon
      real             :: knownj   ! Y-location of known lat/lon
      real             :: latinc   ! Latitude increments in degrees
      real             :: loninc   ! Longitude increments in degrees
      logical          :: init     ! Flag to indicate if this struct is
                                 ! ready for use
   end type proj_info

   type(proj_info) :: map_info

   character(len=10000),private :: message(50)

contains

subroutine da_llxy_latlon(lat, lon, proj, x, y)

   !-----------------------------------------------------------------------
   ! Purpose: Compute the x/y location of a lat/lon on a LATLON grid.
   !-----------------------------------------------------------------------

   implicit none

   real, intent(in)             :: lat
   real, intent(in)             :: lon
   type(proj_info), intent(in)  :: proj
   real, intent(out)            :: x
   real, intent(out)            :: y

   real                         :: deltalat
   real                         :: deltalon
   real                         :: lon360
   real                         :: latinc
   real                         :: loninc

   ! Extract the latitude and longitude increments for this grid
   ! (e.g., 2.5 deg for NCEP reanalysis) from the proj structure, where
   ! loninc is saved in the stdlon tag and latinc is saved in truelat1

   latinc = proj%truelat1
   loninc = proj%stdlon

   ! Compute deltalat and deltalon as the difference between the input
   ! lat/lon and the origin lat/lon

   deltalat = lat - proj%lat1

   ! To account for issues around the dateline, convert the incoming
   ! longitudes to be 0->360.0
   if (lon < 0) then
      lon360 = lon + 360.0
   else
      lon360 = lon
   end if
   deltalon = lon360 - proj%lon1

   ! Compute x/y
   x = deltalon/loninc + 1.0
   y = deltalat/latinc + 1.0

end subroutine da_llxy_latlon

subroutine da_llxy_lc(lat, lon, proj, x, y)

   !-----------------------------------------------------------------------
   ! Purpose: compute the geographical latitude and longitude values
   ! to the cartesian x/y on a Lambert Conformal projection.
   !-----------------------------------------------------------------------

   implicit none

   real, intent(in)              :: lat      ! Latitude (-90->90 deg N)
   real, intent(in)              :: lon      ! Longitude (-180->180 E)
   type(proj_info),intent(in)    :: proj     ! Projection info structure

   real, intent(out)             :: x        ! Cartesian X coordinate
   real, intent(out)             :: y        ! Cartesian Y coordinate

   real                          :: arg
   real                          :: deltalon
   real                          :: tl1r
   real                          :: rm
   real                          :: ctl1r

   ! Compute deltalon between known longitude and standard lon and ensure
   ! it is not in the cut zone
   deltalon = lon - proj%stdlon
   if (deltalon > +180.0) deltalon = deltalon - 360.0
   if (deltalon < -180.0) deltalon = deltalon + 360.0

   ! Convert truelat1 to radian and compute COS for later use
   tl1r = proj%truelat1 * rad_per_deg
   ctl1r = COS(tl1r)

   ! Radius to desired point
   rm = proj%rebydx * ctl1r/proj%cone * &
       (TAN((90.0*proj%hemi-lat)*rad_per_deg/2.0) / &
        TAN((90.0*proj%hemi-proj%truelat1)*rad_per_deg/2.0))**proj%cone

   arg = proj%cone*(deltalon*rad_per_deg)
   x = proj%polei + proj%hemi * rm * Sin(arg)
   y = proj%polej - rm * COS(arg)

   ! Finally, if we are in the southern hemisphere, flip the i/j
   ! values to a coordinate system where (1,1) is the SW corner
   ! (what we assume) which is different than the original NCEP
   ! algorithms which used the NE corner as the origin in the
   ! southern hemisphere (left-hand vs. right-hand coordinate?)
   if (proj%hemi == -1.0) then
      x = 2.0 - x
      y = 2.0 - y
   end if

end subroutine da_llxy_lc

subroutine da_llxy_merc(lat, lon, proj, x, y)

   !-----------------------------------------------------------------------
   ! Purpose: Compute x,y coordinate from lat lon for mercator projection
   !-----------------------------------------------------------------------

   implicit none

   real, intent(in)              :: lat
   real, intent(in)              :: lon
   type(proj_info),intent(in)    :: proj
   real,intent(out)              :: x
   real,intent(out)              :: y
   real                          :: deltalon

   deltalon = lon - proj%lon1
   if (deltalon < -180.0) deltalon = deltalon + 360.0
   if (deltalon > 180.0) deltalon = deltalon - 360.0
   x = 1.0 + (deltalon/(proj%dlon*deg_per_rad))
   y = 1.0 + (ALOG(TAN(0.5*((lat + 90.0) * rad_per_deg)))) / &
           proj%dlon - proj%rsw

end subroutine da_llxy_merc

subroutine da_llxy_ps(lat,lon,proj,x,y)

   !-----------------------------------------------------------------------
   ! Purpose: Given latitude (-90 to 90), longitude (-180 to 180), and the
   ! standard polar-stereographic projection information via the
   ! public proj structure, this routine returns the x/y indices which
   ! if within the domain range from 1->nx and 1->ny, respectively.
   !-----------------------------------------------------------------------

   implicit none

   real, intent(in)               :: lat
   real, intent(in)               :: lon
   type(proj_info),intent(in)     :: proj

   real, intent(out)              :: x !(x-index)
   real, intent(out)              :: y !(y-index)

   real                           :: reflon
   real                           :: scale_top
   real                           :: ala
   real                           :: alo
   real                           :: rm

   reflon = proj%stdlon + 90.0

   ! Compute numerator term of map scale factor

   scale_top = 1.0 + proj%hemi * Sin(proj%truelat1 * rad_per_deg)

   ! Find radius to desired point
   ala = lat * rad_per_deg
   rm = proj%rebydx * COS(ala) * scale_top/(1.0 + proj%hemi *Sin(ala))
   alo = (lon - reflon) * rad_per_deg
   x = proj%polei + rm * COS(alo)
   y = proj%polej + proj%hemi * rm * Sin(alo)

end subroutine da_llxy_ps

subroutine da_llxy_wrf(proj, lat, lon, x, y)

   !-----------------------------------------------------------------------
   ! Purpose: Converts input lat/lon values to the cartesian (x, y) value
   ! for the given projection.
   !-----------------------------------------------------------------------

   implicit none

   type(proj_info), intent(in)  :: proj
   real,            intent(in)  :: lat
   real,            intent(in)  :: lon
   real,            intent(out) :: x
   real,            intent(out) :: y

   if (.NOT.proj%init) then
      write(stdout,*) "da_llxy_wrf.inc"// &
           "You have not called map_set for this projection!"
      stop
   end if

   select case(proj%code)

      case(PROJ_LATLON)
         call da_llxy_latlon(lat,lon,proj,x,y)

      case(PROJ_MERC)
         call da_llxy_merc(lat,lon,proj,x,y)
         x = x + proj%knowni - 1.0
         y = y + proj%knownj - 1.0

      case(PROJ_PS)
         call da_llxy_ps(lat,lon,proj,x,y)

      case(PROJ_LC)
         call da_llxy_lc(lat,lon,proj,x,y)
         x = x + proj%knowni - 1.0
         y = y + proj%knownj - 1.0

      case default
         write(unit=message(1),fmt='(A,I2)') &
            'Unrecognized map projection code: ', proj%code
         write(stdout,*) "da_llxy_wrf.inc"//message(1:1)
         stop
   end select

end subroutine da_llxy_wrf

subroutine da_xyll(proj, xx, yy, lat, lon)

   !-----------------------------------------------------------------------
   ! Purpose: Computes geographical latitude and longitude for a given (i,j)
   ! point in a grid with a projection of proj
   !-----------------------------------------------------------------------

   implicit none

   type(proj_info), intent(in)  :: proj
   real,            intent(in)  :: xx
   real,            intent(in)  :: yy
   real,            intent(out) :: lat
   real,            intent(out) :: lon

   real :: x, y

   if (.NOT.proj%init) then
      write(stdout,*) "da_xyll.inc"// &
           "You have not called map_set for this projection!"
      stop
   end if

   x = xx
   y = yy

   select case (proj%code)
      case (PROJ_LATLON)
         call da_xyll_latlon(x, y, proj, lat, lon)

      case (PROJ_MERC)
         x = xx - proj%knowni + 1.0
         y = yy - proj%knownj + 1.0
         call da_xyll_merc(x, y, proj, lat, lon)

      case (PROJ_PS)
         call da_xyll_ps(x, y, proj, lat, lon)

      case (PROJ_LC)

         x = xx - proj%knowni + 1.0
         y = yy - proj%knownj + 1.0
         call da_xyll_lc(x, y, proj, lat, lon)

      case default
         write(unit=message(1),fmt='(A,I2)') &
            "Unrecognized map projection code: ", proj%code
         write(stdout,*) "da_xyll.inc"//message(1:1)
         stop

   end select

end subroutine da_xyll

subroutine da_xyll_latlon(x, y, proj, lat, lon)

   !-----------------------------------------------------------------------
   ! Purpose: Compute the lat/lon location of an x/y on a LATLON grid.
   !-----------------------------------------------------------------------

   implicit none

   real, intent(in)             :: x
   real, intent(in)             :: y
   type(proj_info), intent(in)  :: proj
   real, intent(out)            :: lat
   real, intent(out)            :: lon

   real                         :: deltalat
   real                         :: deltalon
   real                         :: latinc
   real                         :: loninc

   ! Extract the latitude and longitude increments for this grid
   ! (e.g., 2.5 deg for NCEP reanalysis) from the proj structure, where
   ! loninc is saved in the stdlon tag and latinc is saved in truelat1

   latinc = proj%truelat1
   loninc = proj%stdlon

   ! Compute deltalat and deltalon

   deltalat = (x-1.0)*latinc
   deltalon = (y-1.0)*loninc
   lat = proj%lat1 + deltalat
   lon = proj%lon1 + deltalon

   if ((ABS(lat) > 90.0).OR.(ABS(deltalon) > 360.0)) then
      ! Off the earth for this grid
      lat = -999.0
      lon = -999.0
   else
      lon = lon + 360.0
      lon = MOD(lon,360.0)
      if (lon > 180.0) lon = lon -360.0
   end if

end subroutine da_xyll_latlon

subroutine da_xyll_lc(x, y, proj, lat, lon)

   ! subroutine da_to convert from the (x,y) cartesian coordinate to the
   ! geographical latitude and longitude for a Lambert Conformal projection.

   implicit none

   real, intent(in)              :: x        ! Cartesian X coordinate
   real, intent(in)              :: y        ! Cartesian Y coordinate
   type(proj_info),intent(in)    :: proj     ! Projection info structure

   real, intent(out)             :: lat      ! Latitude (-90->90 deg N)
   real, intent(out)             :: lon      ! Longitude (-180->180 E)

   real                          :: inew
   real                          :: jnew
   real                          :: r
   real                          :: chi,chi1,chi2
   real                          :: r2
   real                          :: xx
   real                          :: yy

   chi1 = (90.0 - proj%hemi*proj%truelat1)*rad_per_deg
   chi2 = (90.0 - proj%hemi*proj%truelat2)*rad_per_deg

   ! See if we are in the southern hemispere and flip the indices
   ! if we are.
   if (proj%hemi == -1.0) then
      inew = -x + 2.0
      jnew = -y + 2.0
   else
      inew = x
      jnew = y
   end if

   ! Compute radius**2 to i/j location
   xx = inew - proj%polei
   yy = proj%polej - jnew
   r2 = (xx*xx + yy*yy)
   r = sqrt(r2)/proj%rebydx

   ! Convert to lat/lon
   if (r2 == 0.0) then
      lat = proj%hemi * 90.0
      lon = proj%stdlon
   else

      ! Longitude
      lon = proj%stdlon + deg_per_rad * ATAN2(proj%hemi*xx,yy)/proj%cone
      lon = MOD(lon+360.0, 360.0)

      ! Latitude.  Latitude determined by solving an equation adapted
      ! from:
      !  Maling, D.H., 1973: Coordinate Systems and Map Projections
      ! Equations #20 in Appendix I.

      if (chi1 == chi2) then
         chi = 2.0*ATAN((r/TAN(chi1))**(1.0/proj%cone) * TAN(chi1*0.5))
      else
         chi = 2.0*ATAN((r*proj%cone/Sin(chi1))**(1.0/proj%cone) * TAN(chi1*0.5))
      end if
      lat = (90.0-chi*deg_per_rad)*proj%hemi
   end if

   if (lon > +180.0) lon = lon - 360.0
   if (lon < -180.0) lon = lon + 360.0

end subroutine da_xyll_lc

subroutine da_xyll_merc(x, y, proj, lat, lon)

   !-----------------------------------------------------------------------
   ! Compute the lat/lon from i/j for mercator projection
   !-----------------------------------------------------------------------

   implicit none

   real,intent(in)               :: x
   real,intent(in)               :: y
   type(proj_info),intent(in)    :: proj
   real, intent(out)             :: lat
   real, intent(out)             :: lon

   lat = 2.0*ATAN(EXP(proj%dlon*(proj%rsw + y-1.0)))*deg_per_rad - 90.0
   lon = (x-1.0)*proj%dlon*deg_per_rad + proj%lon1
   if (lon > 180.0) lon = lon - 360.0
   if (lon < -180.0) lon = lon + 360.0

end subroutine da_xyll_merc

subroutine da_xyll_ps(x, y, proj, lat, lon)

   ! This is the inverse subroutine da_of llij_ps.  It returns the
   ! latitude and longitude of an x/y point given the projection info
   ! structure.

   implicit none

   real, intent(in)                    :: x    ! Column
   real, intent(in)                    :: y    ! Row
   type (proj_info), intent(in)        :: proj

   real, intent(out)                   :: lat     ! -90 -> 90 North
   real, intent(out)                   :: lon     ! -180 -> 180 East

   real                                :: reflon
   real                                :: scale_top
   real                                :: xx,yy
   real                                :: gi2, r2
   real                                :: arccos

   ! Compute the reference longitude by rotating 90 degrees to the east
   ! to find the longitude line parallel to the positive x-axis.
   reflon = proj%stdlon + 90.0

   ! Compute numerator term of map scale factor
   scale_top = 1.0 + proj%hemi * Sin(proj%truelat1 * rad_per_deg)

   ! Compute radius to point of interest
   xx = x - proj%polei
   yy = (y - proj%polej) * proj%hemi
   r2 = xx**2 + yy**2

   ! Now the magic code
   if (r2 == 0.0) then
      lat = proj%hemi * 90.0
      lon = reflon
   else
      gi2 = (proj%rebydx * scale_top)**2.0
      lat = deg_per_rad * proj%hemi * ASin((gi2-r2)/(gi2+r2))
      arccos = ACOS(xx/sqrt(r2))
      if (yy > 0) then
         lon = reflon + deg_per_rad * arccos
      else
         lon = reflon - deg_per_rad * arccos
      end if
   end if

   ! Convert to a -180 -> 180 East convention
   if (lon > 180.0) lon = lon - 360.0
   if (lon < -180.0) lon = lon + 360.0

end subroutine da_xyll_ps

subroutine da_set_lc(proj)

   !-----------------------------------------------------------------------
   ! Purpose: Initialize the remaining items in the proj structure for a
   ! lambert conformal grid.
   !-----------------------------------------------------------------------

   implicit none

   type(proj_info), intent(inout) :: proj

   real :: arg
   real :: deltalon1
   real :: tl1r
   real :: ctl1r

   ! Compute cone factor
   call da_lc_cone(proj%truelat1, proj%truelat2, proj%cone)
   if (print_detail_map) then
      write(unit=stdout, fmt='(A,F8.6)') 'Computed cone factor: ', proj%cone
   end if
   ! Compute longitude differences and ensure we stay out of the
   ! forbidden "cut zone"
   deltalon1 = proj%lon1 - proj%stdlon
   if (deltalon1 .gt. +180.0) deltalon1 = deltalon1 - 360.0
   if (deltalon1 .lt. -180.0) deltalon1 = deltalon1 + 360.0

   ! Convert truelat1 to radian and compute COS for later use
   tl1r = proj%truelat1 * rad_per_deg
   ctl1r = COS(tl1r)

   ! Compute the radius to our known lower-left (SW) corner
   proj%rsw = proj%rebydx * ctl1r/proj%cone * &
           (TAN((90.0*proj%hemi-proj%lat1)*rad_per_deg/2.0) / &
            TAN((90.0*proj%hemi-proj%truelat1)*rad_per_deg/2.0))**proj%cone

   ! Find pole point
   arg = proj%cone*(deltalon1*rad_per_deg)
   proj%polei = 1.0 - proj%hemi * proj%rsw * Sin(arg)
   proj%polej = 1.0 + proj%rsw * COS(arg)
   if (print_detail_map) then
      write(unit=stdout,fmt='(A,2F10.3)') 'Computed pole i/j = ', proj%polei, proj%polej
   end if

end subroutine da_set_lc

subroutine da_set_ps(proj)

   ! Initializes a polar-stereographic map projection from the partially
   ! filled proj structure. This routine computes the radius to the
   ! southwest corner and computes the i/j location of the pole for use
   ! in llij_ps and ijll_ps.

   implicit none

   type(proj_info), intent(inout)    :: proj

   real :: ala1
   real :: alo1
   real :: reflon
   real :: scale_top

   ! To define the cone factor for polar stereographic projection
   proj%cone = 1.0

   reflon = proj%stdlon + 90.0

   ! Compute numerator term of map scale factor
   scale_top = 1.0 + proj%hemi * Sin(proj%truelat1 * rad_per_deg)

   ! Compute radius to lower-left (SW) corner
   ala1 = proj%lat1 * rad_per_deg
   proj%rsw = proj%rebydx*COS(ala1)*scale_top/(1.0+proj%hemi*Sin(ala1))

   ! Find the pole point
   alo1 = (proj%lon1 - reflon) * rad_per_deg
   proj%polei = proj%knowni - proj%rsw * COS(alo1)
   proj%polej = proj%knownj - proj%hemi * proj%rsw * Sin(alo1)
   if (print_detail_map) then
      write(unit=stdout,fmt='(A,2F10.1)') 'Computed (I,J) of pole point: ',proj%polei,proj%polej
   end if

end subroutine da_set_ps

subroutine da_map_init(proj)

   !-----------------------------------------------------------------------
   ! Purpose: Initializes the map projection structure to missing values
   !-----------------------------------------------------------------------

   implicit none

   type(proj_info), intent(inout)  :: proj

   proj%lat1     = -999.9
   proj%lon1     = -999.9
   proj%dx       = -999.9
   proj%stdlon   = -999.9
   proj%truelat1 = -999.9
   proj%truelat2 = -999.9
   proj%hemi     = 0.0
   proj%cone     = -999.9
   proj%polei    = -999.9
   proj%polej    = -999.9
   proj%rsw      = -999.9
   proj%knowni   = -999.9
   proj%knownj   = -999.9
   proj%latinc   = -999.9
   proj%loninc   = -999.9
   proj%init     = .false.

end subroutine da_map_init

subroutine da_map_set(proj_code,lat1,lon1,knowni,knownj,dx,stdlon,truelat1,truelat2,latinc,loninc,proj)
   ! Given a partially filled proj_info structure, this routine computes
   ! polei, polej, rsw, and cone (if LC projection) to complete the
   ! structure.  This allows us to eliminate redundant calculations when
   ! calling the coordinate conversion routines multiple times for the
   ! same map.
   ! This will generally be the first routine called when a user wants
   ! to be able to use the coordinate conversion routines, and it
   ! will call the appropriate subroutines based on the
   ! proj%code which indicates which projection type  this is.

   implicit none

   integer,         intent(in)  :: proj_code
   real,            intent(in)  :: lat1
   real,            intent(in)  :: lon1
   real,            intent(in)  :: dx
   real,            intent(in)  :: stdlon
   real,            intent(in)  :: truelat1
   real,            intent(in)  :: truelat2
   real,            intent(in)  :: knowni , knownj
   real,            intent(in)  :: latinc, loninc
   type(proj_info), intent(out) :: proj

   ! First, check for validity of mandatory variables in proj
   if (ABS(lat1) > 90.0) then
      write(stdout,*) "da_map_set.inc"// &
         "Latitude of origin corner required as follows: -90N <= lat1 < = 90N"
      stop
   end if
   if (ABS(lon1) > 180.0) then
      write(stdout,*) "da_map_set.inc"// &
           "Longitude of origin required as follows: -180E <= lon1 <= 180W"
      stop
   end if
   if ((dx .LE. 0.0).AND.(proj_code .NE. PROJ_LATLON)) then
      write(stdout,*)  "da_map_set.inc"// &
           "Require grid spacing (dx) in meters be positive!"
      stop
   end if
   if ((ABS(stdlon) > 180.0).AND.(proj_code .NE. PROJ_MERC)) then
      write(stdout,*) "da_map_set.inc"// &
           "Need orientation longitude (stdlon) as: -180E <= lon1 <= 180W"
      stop
   end if
   if (proj%code .NE. PROJ_LATLON .and. ABS(truelat1)>90.0) then
      write(stdout,*) "da_map_set.inc"// &
           "Set true latitude 1 for all projections!"
      stop
   end if

   call da_map_init(proj)
   proj%code  = proj_code
   proj%lat1 = lat1
   proj%lon1 = lon1
   proj%knowni = knowni
   proj%knownj = knownj
   proj%dx    = dx
   proj%stdlon = stdlon
   proj%truelat1 = truelat1
   proj%truelat2 = truelat2
   proj%latinc   = latinc
   proj%loninc   = loninc
   if (proj%code .NE. PROJ_LATLON) then
      proj%dx = dx
      if (truelat1 < 0.0) then
         proj%hemi = -1.0
      else
         proj%hemi = 1.0
      end if
      proj%rebydx = earth_radius_m / dx
   end if
   pick_proj: select case(proj%code)

      case(PROJ_PS)
         if (print_detail_map) then
            write(unit=stdout,fmt='(A)') 'Setting up POLAR STEREOGRAPHIC map...'
         end if
         call da_set_ps(proj)

      case(PROJ_LC)
         if (print_detail_map) then
            write(unit=stdout,fmt='(A)') 'Setting up LAMBERT CONFORMAL map...'
         end if
         if (ABS(proj%truelat2) > 90.0) then
            if (print_detail_map) then
               write(unit=stdout,fmt='(A)') 'Second true latitude not set, assuming a tangent'
               write(unit=stdout,fmt='(A,F10.3)') 'projection at truelat1: ', proj%truelat1
            end if
            proj%truelat2=proj%truelat1
         end if
         call da_set_lc(proj)

      case (PROJ_MERC)
         if (print_detail_map) then
            write(unit=stdout,fmt='(A)') 'Setting up MERCATOR map...'
         end if
         call da_set_merc(proj)

      case (PROJ_LATLON)
         if (print_detail_map) then
            write(unit=stdout,fmt='(A)') 'Setting up CYLinDRICAL EQUIDISTANT LATLON map...'
         end if
         ! Convert lon1 to 0->360 notation
         if (proj%lon1 < 0.0) proj%lon1 = proj%lon1 + 360.0

         proj%cone = 1.0
      case default
         write(unit=message(1),fmt='(A,I2)') 'Unknown projection code: ', proj%code
         write(stdout,*) "da_map_set.inc"//message(1:1)
         stop

   end select pick_proj
   proj%init = .true.

end subroutine da_map_set

subroutine da_set_merc(proj)

   !--------------------------------------------------------------------------
   ! Purpose: Sets up the remaining basic elements for the mercator projection
   !--------------------------------------------------------------------------

   implicit none

   type(proj_info), intent(inout)       :: proj

   real :: clain

   !  Preliminary variables

   clain = COS(rad_per_deg*proj%truelat1)
   proj%dlon = proj%dx / (earth_radius_m * clain)

   ! Compute distance from equator to origin, and store in the
   ! proj%rsw tag.

   proj%rsw = 0.0
   if (proj%lat1 .NE. 0.0) then
      proj%rsw = (alog(tan(0.5*((proj%lat1+90.)*rad_per_deg))))/proj%dlon
   end if

end subroutine da_set_merc

subroutine da_lc_cone(truelat1, truelat2, cone)

   !------------------------------------------------------------------------
   ! Purpose: compute the cone factor of a Lambert Conformal projection
   !------------------------------------------------------------------------

   implicit none

   real, intent(in)             :: truelat1  ! (-90 -> 90 degrees N)
   real, intent(in)             :: truelat2  !   "   "  "   "     "
   real, intent(out)            :: cone

   ! First, see if this is a secant or tangent projection.  For tangent
   ! projections, truelat1 = truelat2 and the cone is tangent to the
   ! Earth's surface at this latitude.  For secant projections, the cone
   ! intersects the Earth's surface at each of the distinctly different
   ! latitudes
   if (abs(truelat1-truelat2) > 0.1) then
      cone = alog10(cos(truelat1*rad_per_deg)) - &
             alog10(cos(truelat2*rad_per_deg))
      cone = cone /(alog10(tan((45.0 - abs(truelat1)/2.0) * rad_per_deg)) - &
             alog10(tan((45.0 - abs(truelat2)/2.0) * rad_per_deg)))
   else
      cone = sin(abs(truelat1)*rad_per_deg)
   end if

end subroutine da_lc_cone

end module da_verif_tools


program main
!Calculate the effective interaction.

use gauss_legendre
use bonn
use ab
use x
implicit none

	integer :: c1,k1,c2,k2,c3,k3,c4,k4,c5,k5,c6,k6
	real(8), dimension(ss,2) :: xi_k
	real(8), dimension(n_theta) :: xx,ww

	complex, dimension(ss,n_theta) :: B0
	complex, dimension(ss,n_theta) :: B1
	complex, dimension(ss,n_theta) :: B66,B55,B34,B12
	call T0(B0,q,T)
	call T1(B1,q,T)
	call Tnn(B66,B55,B34,B12,q,T)

	call xi(q,xi_k)
	call gauss_legendre_quadrature(n_theta,0.0d0,pi,xx,ww)

	open(unit = 10, file = 'calc/g0_1.d')
	open(unit = 20, file = 'calc/g1_1.d')
	open(unit = 30, file = 'calc/g66_1.d')
	open(unit = 40, file = 'calc/g55_1.d')
	open(unit = 50, file = 'calc/g34_1.d')
	open(unit = 60, file = 'calc/g12_1.d')

	!^0G
	do k1 = 1,n_theta

		do c1 = 1,ss

			write(10,*) real(B0(c1,k1)),aimag(B0(c1,k1)),xi_k(c1,1),xi_k(c1,2),xx(k1)

		enddo

	enddo

	!^1G
	do k2 = 1,n_theta

		do c2 = 1,ss

			write(20,*) real(B1(c2,k2)),aimag(B1(c2,k2)),xi_k(c2,1),xi_k(c2,2),xx(k2)

		enddo

	enddo

	!^66G
	do k3 = 1,n_theta

		do c3 = 1,ss

			write(30,*) real(B66(c3,k3)),aimag(B66(c3,k3)),xi_k(c3,1),xi_k(c3,2),xx(k3)

		enddo

	enddo

	!^55G
	do k4 = 1,n_theta

		do c4 = 1,ss

			write(40,*) real(B55(c4,k4)),aimag(B55(c4,k4)),xi_k(c4,1),xi_k(c4,2),xx(k4)

		enddo

	enddo

	!^34G
	do k5 = 1,n_theta

		do c5 = 1,ss

			write(50,*) real(B34(c5,k5)),aimag(B34(c5,k5)),xi_k(c5,1),xi_k(c5,2),xx(k5)

		enddo

	enddo

	!^12G
	do k6 = 1,n_theta

		do c6 = 1,ss

			write(60,*) real(B12(c6,k6)),aimag(B12(c6,k6)),xi_k(c6,1),xi_k(c6,2),xx(k6)

		enddo

	enddo

	close(10)
	close(20)
	close(30)
	close(40)
	close(50)
	close(60)

end program


module physical_constants

  use amrex_fort_module, only: rt => amrex_real

  implicit none

  real(rt), parameter :: pi = 3.141592653589793238462643383279502884197e0_rt
  real(rt), parameter :: cm_per_fm = 1.0e-13_rt

  ! From 2014 CODATA recommended values
  real(rt), parameter :: clight  = 299792458e2_rt  ! cm/s

  real(rt), parameter :: N_avo = 6.022140857e23_rt ! 1/mol

  real(rt), parameter :: gram_per_amu = 1660539.040e-30_rt

  real(rt), parameter :: erg_per_eV  = 1.6021766208e-12_rt
  real(rt), parameter :: erg_per_MeV = erg_per_eV * 1.0e6_rt
  real(rt), parameter :: gram_per_MeV = erg_per_MeV / clight**2

end module physical_constants


      SUBROUTINE foranl(nu, nv, nfp, nunv, lasym)
      USE stel_kinds
      USE booz_persistent, ONLY: cosm_b, cosn_b, sinm_b, sinn_b,
     1    cosm_nyq, cosn_nyq, sinm_nyq, sinn_nyq, thgrd, ztgrd
      USE booz_params, ONLY: mpol1, ntor, mpol_nyq, ntor_nyq
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER :: nu, nv, nfp, nunv
      LOGICAL, INTENT(in) :: lasym
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: lk, lt, lz, istat=0
      REAL(rprec) :: dth, dzt, twopi
C-----------------------------------------------
      IF (.not.ALLOCATED(cosm_b)) ALLOCATE (
     1    cosm_b(nunv,0:mpol1), sinm_b(nunv,0:mpol1),
     2    cosn_b(nunv,0:ntor),  sinn_b(nunv,0:ntor),
     3    cosm_nyq(nunv,0:mpol_nyq), sinm_nyq(nunv,0:mpol_nyq),
     4    cosn_nyq(nunv,0:ntor_nyq),  sinn_nyq(nunv,0:ntor_nyq),
     6    thgrd(nunv), ztgrd(nunv), stat=istat)
      IF (istat .ne. 0) STOP 'Allocation error in foranl'

      twopi = 8*ATAN(1.0_dp)
!
!     COMPUTE POLOIDAL (thgrd) AND TOROIDAL (ztgrd) ANGLES
!
      IF (lasym) THEN
         dth = twopi/nu                  !USE THIS FOR FULL 2-pi
      ELSE
         dth = twopi/(2*(nu-1))          !Half-around in theta
      END IF

      dzt = twopi/(nv*nfp)
      lk = 0

      DO lt = 1, nu
         DO lz=1, nv
           lk = lk + 1
           thgrd(lk) = (lt-1)*dth
           ztgrd(lk) = (lz-1)*dzt
          END DO
      END DO

      CALL trigfunc (thgrd, ztgrd, cosm_b, sinm_b, cosn_b, sinn_b,
     1               mpol1, ntor, nunv)

      CALL trigfunc (thgrd, ztgrd, cosm_nyq, sinm_nyq, cosn_nyq,
     1               sinn_nyq, mpol_nyq, ntor_nyq, nunv)

      END SUBROUTINE foranl