c*****************************************************************
c
c NAME:
c	sngdbl
c FUNCTION:
c	benchmark for single and double precision fortran performance
c SYNTAX:
c	sngdbl [len]
c ON INPUT:
c	len: vector lenght
c ON OUTPUT:
c	some timing and Mflop/s results
c CALLS:
c
c COMMENTS:
c
c LIBRARIES:
c
c REFERENCES:
c
c VERSION(S):
c	1. original version                         j.behrens 09/1995
c   2. updated for Scientific Software Development course
c      buggy code...                            j.behrens 06/2012
c
c*****************************************************************
	program sngdbl
c
c parameters
	parameter (maxm=   1536) ! max. matrix size
	parameter (minm=     50) ! max. matrix size
	parameter (maxv=2300000) ! max. vector length
	parameter (maxa=   maxm) ! max. auxiliary vector length
	parameter (maxs=     50) ! max. sparse matrix bandwidth
	parameter (maxr=     20) ! max. no. of benchmarks
c
c local declarations
c fields and matrices
	real smata(maxm,maxm), smatb(maxm,maxm), smatc(maxm,maxm),
     *	  smats(maxs,maxv)
	double precision dmata(maxm,maxm), dmatb(maxm,maxm),
     *	  dmatc(maxm,maxm), dmats(maxs,maxv)
	real sveca(maxv), svecb(maxv)
	double precision dveca(maxv), dvecb(maxv)
	real sscla
	double precision dscla
	integer imati(maxs,maxv)
c
c other declarations
c	character*8 nstri
c this is for cray compilers (posix standard command line input)
	character*8 nstri
	integer i1, i2
c end cray section
	real rmega, flops(maxr), times(maxr), t1, t2, to
	real opsmm, opsmv, opssx, opsdp
	character*8 crout(maxr)
c
c read  commandline arguments
	call getarg(1,nstri)
c this is for cray compilers (posix standard command line input)
c	call pxfgetarg(1,nstri,i1,i2)
c end cray section
	if(nstri.eq.'        ') then
	  nbas= minm
	else if (nstri.eq.'-h      ') then
	  write(6,2000)
	  stop 0
	else
	  read(nstri,*) nbas
	  if(nbas.gt.maxm) then
	    write(6,*) 'ERROR: n > maximum lenght = ', maxm
	    stop 1
	  else if (nbas.lt.minm) then
	    write(6,*) 'ERROR: n < minimum lenght = ', minm
	    stop 1
	  endif
	endif
c
c actual matrix size and vector length
	nmat= nbas
	nvec= nbas* nbas
c
c initialize
	call sinit(smata,smatb,smatc,nmat,nmat,sveca,svecb,nvec)
	call dinit(dmata,dmatb,dmatc,nmat,nmat,dveca,dvecb,nvec)
	sscla= sveca(10)
	dscla= dveca(10)
	do 20 j=1,nvec
	  do 21 i=1,maxs
	    smats(i,j)= float(i)* sveca(i)
	    dmats(i,j)= dble(i)* dveca(i)
	    imati(i,j)= mod(j+i,nvec)
 21	  continue
 20	continue
c
c determine timing routine overhead
	to= 0.
	do 10 i=1,10
	  t1= ticktock()
	  t2= ticktock()
	  to= to+ (t2- t1)
 10	continue
	to= to/ 10.
c
c operation counts
	ir= 0
	opsmm= float(nmat* nmat* nmat* 2)
	opsmv= float(nvec* maxs* 2)
	opssx= float(nvec* 100* 2)
	opsdp= float(nvec* 100* 2)
	rmega= 1./1.e6
c
c --------------- single precision part ------------------
c
c matrix-matrix multiply
	t1= ticktock()
	call smatmat(smata,smatb,smatc,nmat,nmat)
	t2= ticktock()
c
	ir= ir+ 1
	times(ir)= t2- t1- to
	flops(ir)= (opsmm* rmega)/ times(ir)
	crout(ir)='s-matmat'
c
c matrix-matrix multiply (unrolled)
	t1= ticktock()
	call smatmtu(smata,smatb,smatc,nmat,nmat)
	t2= ticktock()
c
	ir= ir+ 1
	times(ir)= t2- t1- to
	flops(ir)= (opsmm* rmega)/ times(ir)
	crout(ir)='s-unroll'
c
c matrix-vector multiply
	t1= ticktock()
	call smatvec(smats,imati,maxs,nvec,sveca,svecb,nvec)
	t2= ticktock()
c
	ir= ir+ 1
	times(ir)= t2- t1- to
	flops(ir)= (opsmv* rmega)/ times(ir)
	crout(ir)='s-matvec'
c
c vector-vector multiply (axpy)
	t1= ticktock()
	call svecsx(sveca,svecb,sscla,nvec)
	t2= ticktock()
c
	ir= ir+ 1
	times(ir)= t2- t1- to
	flops(ir)= (opssx* rmega)/ times(ir)
	crout(ir)='  s-axpy'
c
c vector-vector multiply (dot)
	t1= ticktock()
	call svecdp(sveca,svecb,sscla,nvec)
	t2= ticktock()
c
	ir= ir+ 1
	times(ir)= t2- t1- to
	flops(ir)= (opsdp* rmega)/ times(ir)
	crout(ir)='s-dotpro'
c
c --------------- double precision part ------------------
c
c matrix-matrix multiply
	t1= ticktock()
	call dmatmat(dmata,dmatb,dmatc,nmat,nmat)
	t2= ticktock()
c
	ir= ir+ 1
	times(ir)= t2- t1- to
	flops(ir)= (opsmm* rmega)/ times(ir)
	crout(ir)='d-matmat'
c
c matrix-matrix multiply (unrolled)
	t1= ticktock()
	call dmatmtu(dmata,dmatb,dmatc,nmat,nmat)
	t2= ticktock()
c
	ir= ir+ 1
	times(ir)= t2- t1- to
	flops(ir)= (opsmm* rmega)/ times(ir)
	crout(ir)='d-unroll'
c
c matrix-vector multiply
	t1= ticktock()
	call dmatvec(dmats,imati,maxs,nvec,dveca,dvecb,nvec)
	t2= ticktock()
c
	ir= ir+ 1
	times(ir)= t2- t1- to
	flops(ir)= (opsmv* rmega)/ times(ir)
	crout(ir)='d-matvec'
c
c vector-vector multiply (axpy)
	t1= ticktock()
	call dvecsx(dveca,dvecb,dscla,nvec)
	t2= ticktock()
c
	ir= ir+ 1
	times(ir)= t2- t1- to
	flops(ir)= (opssx* rmega)/ times(ir)
	crout(ir)='  d-axpy'
c
c vector-vector multiply (dot)
	t1= ticktock()
	call dvecdp(dveca,dvecb,dscla,nvec)
	t2= ticktock()
c
	ir= ir+ 1
	times(ir)= t2- t1- to
	flops(ir)= (opsdp* rmega)/ times(ir)
	crout(ir)='d-dotpro'
c
c print out in nice format
	call print_results(times,flops,crout,ir,nmat,nvec)
c
	stop
c
c formats
 2000	format(1x,'USAGE: sngdbl [-h|n]',/
     *	5x,'-h: show this help screen',/
     *	5x,' n: matrix size/vector length',/
     *	1x,'PURPOSE: benchmark for cg-like applications,',/
     *	5x,'single and double precision performance.',/
     *	1x,'(c) j. behrens, 9/95')
	end
c*****************************************************************
      subroutine smatgen(aa,lda,n,norma)
      real aa(lda,n),norma
c
      init = 1325
      norma = 0.0
      do 30 j = 1,n
        do 20 i = 1,lda
          init = mod(3125*init,65536)
          aa(i,j) = (init - 32768.0)/16384.0
          norma = max(abs(aa(i,j)), norma)
   20   continue
   30 continue
      return
      end
c*****************************************************************
      subroutine svecgen(aa,n,norma)
      real aa(n),norma
c
      init = 1325
      norma = 0.0
      do 30 j = 1,n
        init = mod(3125*init,65536)
        aa(j) = (init - 32768.0)/16384.0
        norma = max(abs(aa(j)), norma)
   30 continue
      return
      end
c*****************************************************************
	subroutine sinit(aa,bb,ee,lda,nm,cc,dd,nv)
c
c local declarations
	real aa(lda,nm), bb(lda,nm), ee(lda,nm), cc(nv), dd(nv), rn
	integer lda, nm, nv
c
c call matgen for aa and bb
	call smatgen(aa,lda,nm,rn)
	call smatgen(bb,lda,nm,rn)
	call smatgen(ee,lda,nm,rn)
c
	call svecgen(cc,nv,rn)
	call svecgen(dd,nv,rn)
c
	return
	end
c*****************************************************************
      subroutine dmatgen(aa,lda,n,norma)
      double precision  aa(lda,n),norma
c
      init = 1325
      norma = 0.0
      do 30 j = 1,n
        do 20 i = 1,lda
          init = mod(3125*init,65536)
          aa(i,j) = (init - 32768.0)/16384.0
          norma = max(abs(aa(i,j)), norma)
   20   continue
   30 continue
      return
      end
c*****************************************************************
      subroutine dvecgen(aa,n,norma)
      double precision  aa(n),norma
c
      init = 1325
      norma = 0.0
      do 30 j = 1,n
        init = mod(3125*init,65536)
        aa(j) = (init - 32768.0)/16384.0
        norma = max(abs(aa(j)), norma)
   30 continue
      return
      end
c*****************************************************************
	subroutine dinit(aa,bb,ee,lda,nm,cc,dd,nv)
c
c local declarations
	double precision aa(lda,nm), bb(lda,nm), ee(lda,nm),
     *	cc(nv), dd(nv), rn
	integer lda, nm, nv
c
c call matgen for aa and bb
	call dmatgen(aa,lda,nm,rn)
	call dmatgen(bb,lda,nm,rn)
	call dmatgen(ee,lda,nm,rn)
c
	call dvecgen(cc,nv,rn)
	call dvecgen(dd,nv,rn)
c
	return
	end
c*****************************************************************
c*****************************************************************
	subroutine smatmat(aa,bb,cc,lda,n)
c
c local declarations
	real aa(lda,n), bb(lda,n), cc(lda,n)
c
c matrixmultiplication
	do 10 k=1,n
	  do 10 j=1,n
	    do 10 i=1,n
 10	      cc(i,j)= cc(i,j)+ aa(i,k)* bb(k,j)
c
	return
	end
c*****************************************************************
	subroutine smatmtu(aa,bb,cc,lda,n)
c
c local declarations
	parameter (lunr=4)
	real aa(lda,n), bb(lda,n), cc(lda,n)
	integer n1, n2, n3
c
c calculate some loop bounds
	n1= int(n/lunr)
	n3= n1* lunr
	n2= n- n3
c
c matrixmultiplication (with loop unrolling)
	do 10 k=1,n3,lunr
	  do 10 j=1,n
	    do 10 i=1,n
 10	      cc(i,j)= cc(i,j)+ aa(i,k)* bb(k,j)
     *			      + aa(i,k+1)* bb(k+1,j)
     *			      + aa(i,k+2)* bb(k+2,j)
     *			      + aa(i,k+3)* bb(k+3,j)
c     *			      + aa(i,k+4)* bb(k+4,j)
c     *			      + aa(i,k+5)* bb(k+5,j)
c     *			      + aa(i,k+6)* bb(k+6,j)
c     *			      + aa(i,k+7)* bb(k+7,j)
c
	do 20 k=n3+1,n
	  do 20 j=1,n
	    do 20 i=1,n
 20	      cc(i,j)= cc(i,j)+ aa(i,k)* bb(k,j)
c
	return
	end
c*****************************************************************
	subroutine smatvec(aa,ii,lda,nm,bb,cc,nv)
c
c local declarations
	real aa(lda,nm), bb(nv), cc(nv)
	integer ii(lda,nm)
c
c matrix-vector multiplication
	do 10 j=1,nm
	  do 10 i=1,lda
 10	      cc(j)= cc(j)+ aa(i,j)* bb(ii(i,j))
c
	return
	end
c*****************************************************************
	subroutine svecsx(aa,bb,cc,nv)
c
c local declarations
	real aa(nv), bb(nv), cc
c
c axpy multiplication
	do 15 i=1,100 ! dummy loop precise timing
	aa(i)= bb(i+1)
	do 10 j=1,nv
 10	  bb(j)= aa(j)* cc+ bb(j)
 15	continue
c
	return
	end
c*****************************************************************
	subroutine svecdp(aa,bb,cc,nv)
c
c local declarations
	real aa(nv), bb(nv), cc
c
c dotproduct multiplication
	do 15 i=1,100 ! dummy loop precise timing
	aa(i)= bb(i+1)
	cc= 0.0
	do 10 j=1,nv
 10	  cc= cc+ aa(j)* bb(j)
 15	continue
c
	return
	end
c*****************************************************************
c*****************************************************************
	subroutine dmatmat(aa,bb,cc,lda,n)
c
c local declarations
	double precision aa(lda,n), bb(lda,n), cc(lda,n)
c
c matrixmultiplication
	do 10 k=1,n
	  do 10 j=1,n
	    do 10 i=1,n
 10	      cc(i,j)= cc(i,j)+ aa(i,k)* bb(k,j)
c
	return
	end
c*****************************************************************
	subroutine dmatmtu(aa,bb,cc,lda,n)
c
c local declarations
	parameter (lunr=4)
	double precision aa(lda,n), bb(lda,n), cc(lda,n)
	integer n1, n2, n3
c
c calculate some loop bounds
	n1= int(n/lunr)
	n3= n1* lunr
	n2= n- n3
c
c matrixmultiplication (with loop unrolling)
	do 10 k=1,n3,lunr
	  do 10 j=1,n
	    do 10 i=1,n
 10	      cc(i,j)= cc(i,j)+ aa(i,k)* bb(k,j)
     *			      + aa(i,k+1)* bb(k+1,j)
     *			      + aa(i,k+2)* bb(k+2,j)
     *			      + aa(i,k+3)* bb(k+3,j)
c     *			      + aa(i,k+4)* bb(k+4,j)
c     *			      + aa(i,k+5)* bb(k+5,j)
c     *			      + aa(i,k+6)* bb(k+6,j)
c     *			      + aa(i,k+7)* bb(k+7,j)
c
	do 20 k=n3+1,n
	  do 20 j=1,n
	    do 20 i=1,n
 20	      cc(i,j)= cc(i,j)+ aa(i,k)* bb(k,j)
c
	return
	end
c*****************************************************************
	subroutine dmatvec(aa,ii,lda,nm,bb,cc,nv)
c
c local declarations
	double precision aa(lda,nm), bb(nv), cc(nv)
	integer ii(lda,nm)
c
c matrix-vector multiplication
	do 10 j=1,nm
	  do 10 i=1,lda
 10	      cc(j)= cc(j)+ aa(i,j)* bb(ii(i,j))
c
	return
	end
c*****************************************************************
	subroutine dvecsx(aa,bb,cc,nv)
c
c local declarations
	double precision aa(nv), bb(nv), cc
c
c axpy multiplication
	do 15 i=1,100 ! dummy loop precise timing
	aa(i)= bb(i+1)
	do 10 j=1,nv
 10	  bb(j)= aa(j)* cc+ bb(j)
 15	continue
c
	return
	end
c*****************************************************************
	subroutine dvecdp(aa,bb,cc,nv)
c
c local declarations
	double precision aa(nv), bb(nv), cc
c
c dotproduct multiplication
	do 15 i=1,100 ! dummy loop precise timing
	aa(i)= bb(i+1)
	cc= 0.0
	do 10 j=1,nv
 10	  cc= cc+ aa(j)* bb(j)
 15	continue
c
	return
	end
c*****************************************************************
	subroutine print_results(times,flops,crout,ir,nm,nv)
c
c local declarations
	integer ir
	character*8 crout(ir)
	real times(ir), flops(ir)
c
c print header
	write(6,1000)
	write(6,1010) nm, nv
	write(6,1000)
c
c print values for each routine
	do 10 i=1,ir
	  write(6,1020) crout(i)
	  write(6,1030) times(i), flops(i)
	  write(6,1001)
 10	continue
c
	write(6,1000)
c
c formats
 1001  FORMAT(1x,
     *    '|------------------------------------------------------|'
     *    )
 1000  FORMAT(1x,
     *    '|======================================================|'
     *    )
 1010  FORMAT(
     *	1x,'|',10x,'Benchmark for CG-like Applications',10x,'|'/
     *  1x,'|',15x,'LinuX Version 1.0 (9/95)',15x,'|'/
     *  1x,'|',18x,'(c) by J. Behrens',19x,'|'/
     *	1x,'|',15x,'Matrix size: ',i8,'**2',15x,'|'/
     *	1x,'|',15x,'Vector length: ',i8,16x,'|')
 1020  FORMAT(
     *	1x,'|',13x,'Results for routine ',a8,13x,'|')
 1030  FORMAT(
     *	1x,'|',6x,'Time (s): ',e11.4,' Mflop/s: ',e11.4,6x,'|')
	return
	end
c*****************************************************************
c this is for compatibility reasons
c*****************************************************************
	real function ticktock()
c
	ticktock= real(tick())
	return
	end


      SUBROUTINE ANALYTIC_T
     &           (N, T, PAR, X, W)
C ---------------------------------------------------------------------------
C     Computes an analytic solution to Laplace's equation in the grid
C     points given by X and stores it in the workspace W.
C     The kind of analytic solution is determined by the parameter
C     ANL_TYPE, which is a common block variable in the file anl_params.inc
C     The analytic solution is stored in the workspace W as follows:
C
C     W (1:N, 1) : PHI_T
C     W (1:N, 3) : PHI_XT
C     W (1:N, 4) : PHI_ZT
C     W (1:N, 5) : PHI_XXT
C     W (1:N, 6) : PHI_XZT
C
C     Due to Laplace's equation we have PHI_XX + PHI_ZZ = 0, so PHI_ZZ
C     is given implicitly as -PHI_XX
C
C ---------------------------------------------------------------------------
      IMPLICIT NONE
      INCLUDE 'knd_params.inc'
      INCLUDE 'anl_params.inc'
C
      INTEGER(KIND=IK) N         ! Nr. of grid points  (IN)
      REAL   (KIND=RK) T         ! Time (IN)
      REAL   (KIND=RK) PAR (*)
      REAL   (KIND=RK) X (4, *)  ! coordinates of grid points (IN)
      REAL   (KIND=RK) W (*)     ! workspace, which will contain
                                 ! the analytic solution (OUT)
C
      CHARACTER*35 MSG
C
      IF (ANL_TYPE .EQ. ANL_LINWAVE) THEN
         CALL LINWAVE_T
     &        (N, T, PAR, X, W)
      ELSE IF (ANL_TYPE .EQ. ANL_RFWAVE) THEN
         CALL RFWAVE_T
     &        (N, T, PAR, X, W)
      ELSE IF (ANL_TYPE .EQ. ANL_NOTAVAIL) THEN
C        THERE'S NO KNOWN SOLUTION, SO W <- 0
         CALL NOTAVAIL
     &        (N, W)
      ELSE
         WRITE (MSG,'(A,I3)')
     &   'Analytic solution not implemented:', ANL_TYPE
         CALL ERROR ('ANALYTIC', MSG)
      END IF
C
      RETURN
      END
      SUBROUTINE LINWAVE_T
     &           (N, T, ANL_PAR, CRD, ANL)
C ---------------------------------------------------------------------------
C     Analytic solution: Linear wave
C
C              A  W  COSH (K (Z + H))
C        PHI = ----  ---------------- * SIN (K (X - X0) - W T)
C                K     SINH (K H)
C
C     A : Wave amplitude    [m.]
C     K : wave number       [1/m.]
C     W : Wave frequency    [rad/s.]
C     H : Water depth       [m.]
C     X0: Wave crest offset [m.]
C
C     ANL (1:N, 2) : PHI_T
C     ANL (1:N, 3) : PHI_X
C     ANL (1:N, 4) : PHI_Z
C     ANL (1:N, 5) : PHI_XX
C     ANL (1:N, 6) : PHI_XZ
C ---------------------------------------------------------------------------
      IMPLICIT NONE
      INCLUDE 'knd_params.inc'
      INCLUDE 'rle_params.inc'
C
      INTEGER(KIND=IK) N           ! Nr. of grid points (IN)
      REAL   (KIND=RK) T           ! Time (IN)
      REAL   (KIND=RK) ANL_PAR (*)
      REAL   (KIND=RK) CRD (4, *)  ! Grid point coordinates (IN)
      REAL   (KIND=RK) ANL (N, *)  ! Analytic solution (OUT)
C
      INTEGER(KIND=IK) I
      REAL   (KIND=RK) A, L, H, X0, K, W
      REAL   (KIND=RK) X, Z, SX, CX, SHZ, CHZ, SHKH, KH, WT, AW2
C
      A  = ANL_PAR (1)
      L  = ANL_PAR (2)
      H  = ANL_PAR (3)
      X0 = ANL_PAR (4)
C
      K    = TWO_PI / L
      KH   = K * H
      W    = SQRT (Grav * K * TANH (KH))
      WT   = W * T
      AW2  = A * W ** 2
      SHKH = SINH (KH)
C
      DO I = 1, N
         X   = CRD (1, I) - X0
         Z   = CRD (2, I)
         SX  = SIN  (K * X - WT)
         CX  = COS  (K * X - WT)
         SHZ = SINH (K * Z + KH) / SHKH
         CHZ = COSH (K * Z + KH) / SHKH
         ANL (I, 1) =  AW2 / K * CHZ * SX * W
         ANL (I, 3) = -AW2     * CHZ * SX
         ANL (I, 4) =  AW2     * SHZ * CX
         ANL (I, 5) = -AW2 * K * CHZ * CX
         ANL (I, 6) = -AW2 * K * SHZ * SX
      END DO
C
      RETURN
      END
      SUBROUTINE RFWAVE_T
     &           (N, T, ANL_PAR, CRD, ANL)
C ---------------------------------------------------------------------------
C     Analytic solution: Rienecker & Fenton type of wave
C
C            __ N
C            \      COSH (J K (Z + H))
C    PHI =   /    B ---------------- * SIN (J K (X - X0 - C T))
C            --    J  COSH (J K H)
C            J = 1                                         2
C                   + (C + B) (X - X0) - (G (R - H) - 1/2 C ) T
C                           0
C
C     K : wave number            [1/m]
C     W : Wave frequency         [rad/s]
C     C : Wave phace velocity    [m/s]
C     H : Water depth            [m]
C     X0: Wave crest offset      [m]
C     B : J-th Fourier component [-]
C      J
C     G : Gravitational accel.   [m/s^2]
C     R : R&F constant           [m]
C
C     ANL (1:N, 2) : PHI_T
C     ANL (1:N, 3) : PHI_XT
C     ANL (1:N, 4) : PHI_ZT
C     ANL (1:N, 5) : PHI_XXT
C     ANL (1:N, 6) : PHI_XZT
C ---------------------------------------------------------------------------
      IMPLICIT NONE
      INCLUDE 'knd_params.inc'
      INCLUDE 'rle_params.inc'
C
      INTEGER(KIND=IK) N           ! Nr. of grid points (IN)
      REAL   (KIND=RK) T           ! Time (IN)
      REAL   (KIND=RK) ANL_PAR (*)
      REAL   (KIND=RK) CRD (4, *)  ! Grid point coordinates (IN)
      REAL   (KIND=RK) ANL (N, *)  ! Analytic solution (OUT)
C
      INTEGER(KIND=IK) I, J, NRF
      REAL   (KIND=RK) L, H, X0, W, K, K2, R, B, B_0, C
      REAL   (KIND=RK) X, Z, AA, SX, CX, SHZ, CHZ, KXT, KZH
C
      L   = ANL_PAR (2)
      H   = ANL_PAR (3)
      X0  = ANL_PAR (4)
      W   = ANL_PAR (5)
      K   = ANL_PAR (6)
      K2  = K ** 2
      C   = W / K
      R   = ANL_PAR (7)
      NRF = INT (ANL_PAR (8))
      B   = (GRAV * (R - H) - 0.5D0 * C ** 2)
      B_0 = ANL_PAR (34)
C
      DO I = 1, N
         X    = CRD (1, I) - X0
         Z    = CRD (2, I)
         KXT  = K * X - W * T
         KZH  = K * (Z + H)
         ANL (I, 1) = 0.0D0
         ANL (I, 3) = 0.0D0
         ANL (I, 4) = 0.0D0
         ANL (I, 5) = 0.0D0
         ANL (I, 6) = 0.0D0
         DO J = 1, NRF
           AA  = ANL_PAR (J + 34) / COSH (J * K * H)
           SX  = SIN  (J * KXT)
           CX  = COS  (J * KXT)
           SHZ = SINH (J * KZH) * AA
           CHZ = COSH (J * KZH) * AA
           ANL (I, 3) = -ANL (I, 3) + CHZ * SX * J
           ANL (I, 4) =  ANL (I, 4) + SHZ * CX * J
           ANL (I, 5) =  ANL (I, 5) - CHZ * CX * J ** 2
           ANL (I, 6) = -ANL (I, 6) + SHZ * SX * J ** 2
         END DO
C        NOTE: for all cases we'll be calculating, the constant
C              C + B_0 will be exactly 0
         ANL (I, 1) = -W *      ANL (I, 3) + B
         ANL (I, 3) =  W * K  * ANL (I, 3)
         ANL (I, 4) =  W * K  * ANL (I, 4)
         ANL (I, 5) =  W * K2 * ANL (I, 5)
         ANL (I, 6) =  W * K2 * ANL (I, 6)
      END DO
C
      RETURN
      END


*DECK DBINOM
      DOUBLE PRECISION FUNCTION DBINOM (N, M)
C***BEGIN PROLOGUE  DBINOM
C***PURPOSE  Compute the binomial coefficients.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C1
C***TYPE      DOUBLE PRECISION (BINOM-S, DBINOM-D)
C***KEYWORDS  BINOMIAL COEFFICIENTS, FNLIB, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DBINOM(N,M) calculates the double precision binomial coefficient
C for integer arguments N and M.  The result is (N!)/((M!)(N-M)!).
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, D9LGMC, DLNREL, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  DBINOM
      DOUBLE PRECISION CORR, FINTMX, SQ2PIL, XK, XN, XNK, D9LGMC,
     1  DLNREL, D1MACH, BILNMX
      LOGICAL FIRST
      SAVE SQ2PIL, BILNMX, FINTMX, FIRST
      DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  DBINOM
      IF (FIRST) THEN
         BILNMX = LOG(D1MACH(2)) - 0.0001D0
         FINTMX = 0.9D0/D1MACH(3)
      ENDIF
      FIRST = .FALSE.
C
      IF (N .LT. 0 .OR. M .LT. 0) CALL XERMSG ('SLATEC', 'DBINOM',
     +   'N OR M LT ZERO', 1, 2)
      IF (N .LT. M) CALL XERMSG ('SLATEC', 'DBINOM', 'N LT M', 2, 2)
C
      K = MIN (M, N-M)
      IF (K.GT.20) GO TO 30
      IF (K*LOG(AMAX0(N,1)).GT.BILNMX) GO TO 30
C
      DBINOM = 1.0D0
      IF (K.EQ.0) RETURN
      DO 20 I=1,K
        XN = N - I + 1
        XK = I
        DBINOM = DBINOM * (XN/XK)
 20   CONTINUE
C
      IF (DBINOM.LT.FINTMX) DBINOM = AINT (DBINOM+0.5D0)
      RETURN
C
C IF K.LT.9, APPROX IS NOT VALID AND ANSWER IS CLOSE TO THE OVERFLOW LIM
 30   IF (K .LT. 9) CALL XERMSG ('SLATEC', 'DBINOM',
     +   'RESULT OVERFLOWS BECAUSE N AND/OR M TOO BIG', 3, 2)
C
      XN = N + 1
      XK = K + 1
      XNK = N - K + 1
C
      CORR = D9LGMC(XN) - D9LGMC(XK) - D9LGMC(XNK)
      DBINOM = XK*LOG(XNK/XK) - XN*DLNREL(-(XK-1.0D0)/XN)
     1  -0.5D0*LOG(XN*XNK/XK) + 1.0D0 - SQ2PIL + CORR
C
      IF (DBINOM .GT. BILNMX) CALL XERMSG ('SLATEC', 'DBINOM',
     +   'RESULT OVERFLOWS BECAUSE N AND/OR M TOO BIG', 3, 2)
C
      DBINOM = EXP (DBINOM)
      IF (DBINOM.LT.FINTMX) DBINOM = AINT (DBINOM+0.5D0)
C
      RETURN
      END


      PROGRAM exmpl1
      INTEGER N1,N2,N3
      PARAMETER (N1=256,N2=256,N3=1)
CU    USES rlft3
      REAL data(N1,N2)
      COMPLEX spec(N1/2,N2),speq(N2)
      EQUIVALENCE (data,spec)
C     ...
      call rlft3(data,speq,N1,N2,N3,1)
C     ...
      call rlft3(data,speq,N1,N2,N3,-1)
C     ...
      END
      PROGRAM exmpl2
      INTEGER N1,N2,N3
      PARAMETER (N1=32,N2=64,N3=16)
CU    USES rlft3
      REAL data(N1,N2,N3)
      COMPLEX spec(N1/2,N2,N3),speq(N2,N3)
      EQUIVALENCE (data,spec)
C     ...
      call rlft3(data,speq,N1,N2,N3,1)
C     ...
      END
      PROGRAM exmpl3
      INTEGER N
      PARAMETER (N=32)
CU    USES rlft3
      INTEGER j
      REAL fac,data1(N,N,N),data2(N,N,N)
      COMPLEX spec1(N/2,N,N),speq1(N,N),spec2(N/2,N,N),speq2(N,N),
     *zpec1(N*N*N/2),zpeq1(N*N),zpec2(N*N*N/2),zpeq2(N*N)
      EQUIVALENCE (data1,spec1,zpec1), (data2,spec2,zpec2),(speq1,
     *zpeq1), (speq2,zpeq2)
C     ...
      call rlft3(data1,speq1,N,N,N,1)
      call rlft3(data2,speq2,N,N,N,1)
      fac=2./(N*N*N)
      do 11 j=1,N*N*N/2
        zpec1(j)=fac*zpec1(j)*zpec2(j)
11    continue
      do 12 j=1,N*N
        zpeq1(j)=fac*zpeq1(j)*zpeq2(j)
12    continue
      call rlft3(data1,speq1,N,N,N,-1)
C     ...
      END

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


      PROGRAM NNEX08
C
      PARAMETER(ISLIM = 11, NUMXOUT = 26, NUMYOUT = 26)
C
      REAL X(ISLIM), Y(ISLIM), Z(ISLIM)
      REAL XI(NUMXOUT), YI(NUMYOUT), ZI(NUMXOUT,NUMYOUT)
C
      DATA X/0.00,0.15,0.10,0.35,0.50,0.55,0.55,0.65,0.85,0.80,1.00/
      DATA Y/0.50,0.80,0.30,0.60,0.35,1.00,0.00,0.55,0.80,0.25,0.45/
C
      DO 130 I=1,ISLIM
          Z(I) = (X(I)-0.25)**2 + (Y(I)-0.50)**2
  130 CONTINUE
C
      XINC = 1./(NUMXOUT-1.)
      DO 20 I=1,NUMXOUT
        XI(I) = REAL(I-1) * XINC
   20 CONTINUE
C
      YINC = 1./(NUMYOUT-1.)
      DO 30 J=1,NUMYOUT
        YI(J) = REAL(J-1) * YINC
   30 CONTINUE
C
      CALL NNSETI('ADF',1)
      CALL NNSETC('ALG','example8.dat')
      CALL NNSETI('IGR',0)
      CALL NATGRIDS(ISLIM,X,Y,Z,NUMXOUT,NUMYOUT,XI,YI,ZI,IER)
C
      STOP
      END


! To define a portable way of precision
!
MODULE kind_module
!
! Description:
!   Define kinds for single and double precision in a portable way
!
! Current Code Owner: Thomas Hauser
!
! History:
!
! Version   Date     Comment
! -------   ----     -------
! 1.0       09-03-08 Original code. Thomas Hauser
!
! Code Description:
!   Language:           Fortran 90.
!   Software Standards: "European Standards for Writing and
!     Documenting Exchangeable Fortran 90 Code".
!

  IMPLICIT NONE
! Global (i.e. public) Declarations:
! Global Parameters:
! Symbolic names for kind type of single and double-precision reals:
! (with at least 6 and 12 digits of accuracy)

  INTEGER, PARAMETER :: single = SELECTED_REAL_KIND(p=6,r=20)
  INTEGER, PARAMETER :: double = SELECTED_REAL_KIND(p=12,r=150)
  INTEGER, PARAMETER :: prec = double

! Symbolic names for kind type of single and double-precision complex:

  INTEGER, PARAMETER :: cSingle = KIND((1.0_single,1.0_single))
  INTEGER, PARAMETER :: cDouble = KIND((1.0_double,1.0_double))
  INTEGER, PARAMETER :: cPrec = cSingle

END MODULE kind_module


      SUBROUTINE ZGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
*  -- LAPACK driver routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, N, NRHS
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX*16         A( LDA, * ), B( LDB, * )
*     ..
*
*  Purpose
*  =======
*
*  ZGESV computes the solution to a complex system of linear equations
*     A * X = B,
*  where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
*
*  The LU decomposition with partial pivoting and row interchanges is
*  used to factor A as
*     A = P * L * U,
*  where P is a permutation matrix, L is unit lower triangular, and U is
*  upper triangular.  The factored form of A is then used to solve the
*  system of equations A * X = B.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The number of linear equations, i.e., the order of the
*          matrix A.  N >= 0.
*
*  NRHS    (input) INTEGER
*          The number of right hand sides, i.e., the number of columns
*          of the matrix B.  NRHS >= 0.
*
*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
*          On entry, the N-by-N coefficient matrix A.
*          On exit, the factors L and U from the factorization
*          A = P*L*U; the unit diagonal elements of L are not stored.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  IPIV    (output) INTEGER array, dimension (N)
*          The pivot indices that define the permutation matrix P;
*          row i of the matrix was interchanged with row IPIV(i).
*
*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
*          On entry, the N-by-NRHS matrix of right hand side matrix B.
*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B.  LDB >= max(1,N).
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*          > 0:  if INFO = i, U(i,i) is exactly zero.  The factorization
*                has been completed, but the factor U is exactly
*                singular, so the solution could not be computed.
*
*  =====================================================================
*
*     .. External Subroutines ..
      EXTERNAL           XERBLA, ZGETRF, ZGETRS
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZGESV ', -INFO )
         RETURN
      END IF
*
*     Compute the LU factorization of A.
*
      CALL ZGETRF( N, N, A, LDA, IPIV, INFO )
      IF( INFO.EQ.0 ) THEN
*
*        Solve the system A*X = B, overwriting B with X.
*
         CALL ZGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB,
     $                INFO )
      END IF
      RETURN
*
*     End of ZGESV
*
      END
      SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO )
*
*  -- LAPACK routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX*16         A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  ZGETF2 computes an LU factorization of a general m-by-n matrix A
*  using partial pivoting with row interchanges.
*
*  The factorization has the form
*     A = P * L * U
*  where P is a permutation matrix, L is lower triangular with unit
*  diagonal elements (lower trapezoidal if m > n), and U is upper
*  triangular (upper trapezoidal if m < n).
*
*  This is the right-looking Level 2 BLAS version of the algorithm.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix A.  M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix A.  N >= 0.
*
*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
*          On entry, the m by n matrix to be factored.
*          On exit, the factors L and U from the factorization
*          A = P*L*U; the unit diagonal elements of L are not stored.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,M).
*
*  IPIV    (output) INTEGER array, dimension (min(M,N))
*          The pivot indices; for 1 <= i <= min(M,N), row i of the
*          matrix was interchanged with row IPIV(i).
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -k, the k-th argument had an illegal value
*          > 0: if INFO = k, U(k,k) is exactly zero. The factorization
*               has been completed, but the factor U is exactly
*               singular, and division by zero will occur if it is used
*               to solve a system of equations.
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX*16         ONE, ZERO
      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
     $                   ZERO = ( 0.0D+0, 0.0D+0 ) )
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION   SFMIN
      INTEGER            I, J, JP
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      INTEGER            IZAMAX
      EXTERNAL           DLAMCH, IZAMAX
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA, ZGERU, ZSCAL, ZSWAP
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZGETF2', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.EQ.0 .OR. N.EQ.0 )
     $   RETURN
*
*     Compute machine safe minimum
*
      SFMIN = DLAMCH('S')
*
      DO 10 J = 1, MIN( M, N )
*
*        Find pivot and test for singularity.
*
         JP = J - 1 + IZAMAX( M-J+1, A( J, J ), 1 )
         IPIV( J ) = JP
         IF( A( JP, J ).NE.ZERO ) THEN
*
*           Apply the interchange to columns 1:N.
*
            IF( JP.NE.J )
     $         CALL ZSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA )
*
*           Compute elements J+1:M of J-th column.
*
            IF( J.LT.M ) THEN
               IF( ABS(A( J, J )) .GE. SFMIN ) THEN
                  CALL ZSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 )
               ELSE
                  DO 20 I = 1, M-J
                     A( J+I, J ) = A( J+I, J ) / A( J, J )
   20             CONTINUE
               END IF
            END IF
*
         ELSE IF( INFO.EQ.0 ) THEN
*
            INFO = J
         END IF
*
         IF( J.LT.MIN( M, N ) ) THEN
*
*           Update trailing submatrix.
*
            CALL ZGERU( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ),
     $                  LDA, A( J+1, J+1 ), LDA )
         END IF
   10 CONTINUE
      RETURN
*
*     End of ZGETF2
*
      END
      SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO )
*
*  -- LAPACK routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX*16         A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  ZGETRF computes an LU factorization of a general M-by-N matrix A
*  using partial pivoting with row interchanges.
*
*  The factorization has the form
*     A = P * L * U
*  where P is a permutation matrix, L is lower triangular with unit
*  diagonal elements (lower trapezoidal if m > n), and U is upper
*  triangular (upper trapezoidal if m < n).
*
*  This is the right-looking Level 3 BLAS version of the algorithm.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix A.  M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix A.  N >= 0.
*
*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
*          On entry, the M-by-N matrix to be factored.
*          On exit, the factors L and U from the factorization
*          A = P*L*U; the unit diagonal elements of L are not stored.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,M).
*
*  IPIV    (output) INTEGER array, dimension (min(M,N))
*          The pivot indices; for 1 <= i <= min(M,N), row i of the
*          matrix was interchanged with row IPIV(i).
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*          > 0:  if INFO = i, U(i,i) is exactly zero. The factorization
*                has been completed, but the factor U is exactly
*                singular, and division by zero will occur if it is used
*                to solve a system of equations.
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX*16         ONE
      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IINFO, J, JB, NB
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA, ZGEMM, ZGETF2, ZLASWP, ZTRSM
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZGETRF', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.EQ.0 .OR. N.EQ.0 )
     $   RETURN
*
*     Determine the block size for this environment.
*
      NB = ILAENV( 1, 'ZGETRF', ' ', M, N, -1, -1 )
      IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN
*
*        Use unblocked code.
*
         CALL ZGETF2( M, N, A, LDA, IPIV, INFO )
      ELSE
*
*        Use blocked code.
*
         DO 20 J = 1, MIN( M, N ), NB
            JB = MIN( MIN( M, N )-J+1, NB )
*
*           Factor diagonal and subdiagonal blocks and test for exact
*           singularity.
*
            CALL ZGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO )
*
*           Adjust INFO and the pivot indices.
*
            IF( INFO.EQ.0 .AND. IINFO.GT.0 )
     $         INFO = IINFO + J - 1
            DO 10 I = J, MIN( M, J+JB-1 )
               IPIV( I ) = J - 1 + IPIV( I )
   10       CONTINUE
*
*           Apply interchanges to columns 1:J-1.
*
            CALL ZLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )
*
            IF( J+JB.LE.N ) THEN
*
*              Apply interchanges to columns J+JB:N.
*
               CALL ZLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1,
     $                      IPIV, 1 )
*
*              Compute block row of U.
*
               CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB,
     $                     N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ),
     $                     LDA )
               IF( J+JB.LE.M ) THEN
*
*                 Update trailing submatrix.
*
                  CALL ZGEMM( 'No transpose', 'No transpose', M-J-JB+1,
     $                        N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA,
     $                        A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ),
     $                        LDA )
               END IF
            END IF
   20    CONTINUE
      END IF
      RETURN
*
*     End of ZGETRF
*
      END
      SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
*  -- LAPACK routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            INFO, LDA, LDB, N, NRHS
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX*16         A( LDA, * ), B( LDB, * )
*     ..
*
*  Purpose
*  =======
*
*  ZGETRS solves a system of linear equations
*     A * X = B,  A**T * X = B,  or  A**H * X = B
*  with a general N-by-N matrix A using the LU factorization computed
*  by ZGETRF.
*
*  Arguments
*  =========
*
*  TRANS   (input) CHARACTER*1
*          Specifies the form of the system of equations:
*          = 'N':  A * X = B     (No transpose)
*          = 'T':  A**T * X = B  (Transpose)
*          = 'C':  A**H * X = B  (Conjugate transpose)
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  NRHS    (input) INTEGER
*          The number of right hand sides, i.e., the number of columns
*          of the matrix B.  NRHS >= 0.
*
*  A       (input) COMPLEX*16 array, dimension (LDA,N)
*          The factors L and U from the factorization A = P*L*U
*          as computed by ZGETRF.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  IPIV    (input) INTEGER array, dimension (N)
*          The pivot indices from ZGETRF; for 1<=i<=N, row i of the
*          matrix was interchanged with row IPIV(i).
*
*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
*          On entry, the right hand side matrix B.
*          On exit, the solution matrix X.
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B.  LDB >= max(1,N).
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX*16         ONE
      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
*     ..
*     .. Local Scalars ..
      LOGICAL            NOTRAN
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA, ZLASWP, ZTRSM
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      NOTRAN = LSAME( TRANS, 'N' )
      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
     $    LSAME( TRANS, 'C' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZGETRS', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 .OR. NRHS.EQ.0 )
     $   RETURN
*
      IF( NOTRAN ) THEN
*
*        Solve A * X = B.
*
*        Apply row interchanges to the right hand sides.
*
         CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, 1 )
*
*        Solve L*X = B, overwriting B with X.
*
         CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS,
     $               ONE, A, LDA, B, LDB )
*
*        Solve U*X = B, overwriting B with X.
*
         CALL ZTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N,
     $               NRHS, ONE, A, LDA, B, LDB )
      ELSE
*
*        Solve A**T * X = B  or A**H * X = B.
*
*        Solve U'*X = B, overwriting B with X.
*
         CALL ZTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE,
     $               A, LDA, B, LDB )
*
*        Solve L'*X = B, overwriting B with X.
*
         CALL ZTRSM( 'Left', 'Lower', TRANS, 'Unit', N, NRHS, ONE, A,
     $               LDA, B, LDB )
*
*        Apply row interchanges to the solution vectors.
*
         CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, -1 )
      END IF
*
      RETURN
*
*     End of ZGETRS
*
      END
      SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX )
*
*  -- LAPACK auxiliary routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            INCX, K1, K2, LDA, N
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX*16         A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  ZLASWP performs a series of row interchanges on the matrix A.
*  One row interchange is initiated for each of rows K1 through K2 of A.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The number of columns of the matrix A.
*
*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
*          On entry, the matrix of column dimension N to which the row
*          interchanges will be applied.
*          On exit, the permuted matrix.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.
*
*  K1      (input) INTEGER
*          The first element of IPIV for which a row interchange will
*          be done.
*
*  K2      (input) INTEGER
*          The last element of IPIV for which a row interchange will
*          be done.
*
*  IPIV    (input) INTEGER array, dimension (K2*abs(INCX))
*          The vector of pivot indices.  Only the elements in positions
*          K1 through K2 of IPIV are accessed.
*          IPIV(K) = L implies rows K and L are to be interchanged.
*
*  INCX    (input) INTEGER
*          The increment between successive values of IPIV.  If IPIV
*          is negative, the pivots are applied in reverse order.
*
*  Further Details
*  ===============
*
*  Modified by
*   R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA
*
* =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, I1, I2, INC, IP, IX, IX0, J, K, N32
      COMPLEX*16         TEMP
*     ..
*     .. Executable Statements ..
*
*     Interchange row I with row IPIV(I) for each of rows K1 through K2.
*
      IF( INCX.GT.0 ) THEN
         IX0 = K1
         I1 = K1
         I2 = K2
         INC = 1
      ELSE IF( INCX.LT.0 ) THEN
         IX0 = 1 + ( 1-K2 )*INCX
         I1 = K2
         I2 = K1
         INC = -1
      ELSE
         RETURN
      END IF
*
      N32 = ( N / 32 )*32
      IF( N32.NE.0 ) THEN
         DO 30 J = 1, N32, 32
            IX = IX0
            DO 20 I = I1, I2, INC
               IP = IPIV( IX )
               IF( IP.NE.I ) THEN
                  DO 10 K = J, J + 31
                     TEMP = A( I, K )
                     A( I, K ) = A( IP, K )
                     A( IP, K ) = TEMP
   10             CONTINUE
               END IF
               IX = IX + INCX
   20       CONTINUE
   30    CONTINUE
      END IF
      IF( N32.NE.N ) THEN
         N32 = N32 + 1
         IX = IX0
         DO 50 I = I1, I2, INC
            IP = IPIV( IX )
            IF( IP.NE.I ) THEN
               DO 40 K = N32, N
                  TEMP = A( I, K )
                  A( I, K ) = A( IP, K )
                  A( IP, K ) = TEMP
   40          CONTINUE
            END IF
            IX = IX + INCX
   50    CONTINUE
      END IF
*
      RETURN
*
*     End of ZLASWP
*
      END

*
************************************************************************
*
      SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 )
*
*  -- LAPACK auxiliary routine (version 1.1) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     October 31, 1992
*
*     .. Scalar Arguments ..
      LOGICAL            IEEE1, RND
      INTEGER            BETA, T
*     ..
*
*  Purpose
*  =======
*
*  DLAMC1 determines the machine parameters given by BETA, T, RND, and
*  IEEE1.
*
*  Arguments
*  =========
*
*  BETA    (output) INTEGER
*          The base of the machine.
*
*  T       (output) INTEGER
*          The number of ( BETA ) digits in the mantissa.
*
*  RND     (output) LOGICAL
*          Specifies whether proper rounding  ( RND = .TRUE. )  or
*          chopping  ( RND = .FALSE. )  occurs in addition. This may not
*          be a reliable guide to the way in which the machine performs
*          its arithmetic.
*
*  IEEE1   (output) LOGICAL
*          Specifies whether rounding appears to be done in the IEEE
*          'round to nearest' style.
*
*  Further Details
*  ===============
*
*  The routine is based on the routine  ENVRON  by Malcolm and
*  incorporates suggestions by Gentleman and Marovich. See
*
*     Malcolm M. A. (1972) Algorithms to reveal properties of
*        floating-point arithmetic. Comms. of the ACM, 15, 949-951.
*
*     Gentleman W. M. and Marovich S. B. (1974) More on algorithms
*        that reveal properties of floating point arithmetic units.
*        Comms. of the ACM, 17, 276-277.
*
* =====================================================================
*
*     .. Local Scalars ..
      LOGICAL            FIRST, LIEEE1, LRND
      INTEGER            LBETA, LT
      DOUBLE PRECISION   A, B, C, F, ONE, QTR, SAVEC, T1, T2
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMC3
      EXTERNAL           DLAMC3
*     ..
*     .. Save statement ..
      SAVE               FIRST, LIEEE1, LBETA, LRND, LT
*     ..
*     .. Data statements ..
      DATA               FIRST / .TRUE. /
*     ..
*     .. Executable Statements ..
*
      IF( FIRST ) THEN
         FIRST = .FALSE.
         ONE = 1
*
*        LBETA,  LIEEE1,  LT and  LRND  are the  local values  of  BETA,
*        IEEE1, T and RND.
*
*        Throughout this routine  we use the function  DLAMC3  to ensure
*        that relevant values are  stored and not held in registers,  or
*        are not affected by optimizers.
*
*        Compute  a = 2.0**m  with the  smallest positive integer m such
*        that
*
*           fl( a + 1.0 ) = a.
*
         A = 1
         C = 1
*
*+       WHILE( C.EQ.ONE )LOOP
   10    CONTINUE
         IF( C.EQ.ONE ) THEN
            A = 2*A
            C = DLAMC3( A, ONE )
            C = DLAMC3( C, -A )
            GO TO 10
         END IF
*+       END WHILE
*
*        Now compute  b = 2.0**m  with the smallest positive integer m
*        such that
*
*           fl( a + b ) .gt. a.
*
         B = 1
         C = DLAMC3( A, B )
*
*+       WHILE( C.EQ.A )LOOP
   20    CONTINUE
         IF( C.EQ.A ) THEN
            B = 2*B
            C = DLAMC3( A, B )
            GO TO 20
         END IF
*+       END WHILE
*
*        Now compute the base.  a and c  are neighbouring floating point
*        numbers  in the  interval  ( beta**t, beta**( t + 1 ) )  and so
*        their difference is beta. Adding 0.25 to c is to ensure that it
*        is truncated to beta and not ( beta - 1 ).
*
         QTR = ONE / 4
         SAVEC = C
         C = DLAMC3( C, -A )
         LBETA = C + QTR
*
*        Now determine whether rounding or chopping occurs,  by adding a
*        bit  less  than  beta/2  and a  bit  more  than  beta/2  to  a.
*
         B = LBETA
         F = DLAMC3( B / 2, -B / 100 )
         C = DLAMC3( F, A )
         IF( C.EQ.A ) THEN
            LRND = .TRUE.
         ELSE
            LRND = .FALSE.
         END IF
         F = DLAMC3( B / 2, B / 100 )
         C = DLAMC3( F, A )
         IF( ( LRND ) .AND. ( C.EQ.A ) )
     $      LRND = .FALSE.
*
*        Try and decide whether rounding is done in the  IEEE  'round to
*        nearest' style. B/2 is half a unit in the last place of the two
*        numbers A and SAVEC. Furthermore, A is even, i.e. has last  bit
*        zero, and SAVEC is odd. Thus adding B/2 to A should not  change
*        A, but adding B/2 to SAVEC should change SAVEC.
*
         T1 = DLAMC3( B / 2, A )
         T2 = DLAMC3( B / 2, SAVEC )
         LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND
*
*        Now find  the  mantissa, t.  It should  be the  integer part of
*        log to the base beta of a,  however it is safer to determine  t
*        by powering.  So we find t as the smallest positive integer for
*        which
*
*           fl( beta**t + 1.0 ) = 1.0.
*
         LT = 0
         A = 1
         C = 1
*
*+       WHILE( C.EQ.ONE )LOOP
   30    CONTINUE
         IF( C.EQ.ONE ) THEN
            LT = LT + 1
            A = A*LBETA
            C = DLAMC3( A, ONE )
            C = DLAMC3( C, -A )
            GO TO 30
         END IF
*+       END WHILE
*
      END IF
*
      BETA = LBETA
      T = LT
      RND = LRND
      IEEE1 = LIEEE1
      RETURN
*
*     End of DLAMC1
*
      END
*
************************************************************************
*
      SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX )
*
*  -- LAPACK auxiliary routine (version 1.1) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     October 31, 1992
*
*     .. Scalar Arguments ..
      LOGICAL            RND
      INTEGER            BETA, EMAX, EMIN, T
      DOUBLE PRECISION   EPS, RMAX, RMIN
*     ..
*
*  Purpose
*  =======
*
*  DLAMC2 determines the machine parameters specified in its argument
*  list.
*
*  Arguments
*  =========
*
*  BETA    (output) INTEGER
*          The base of the machine.
*
*  T       (output) INTEGER
*          The number of ( BETA ) digits in the mantissa.
*
*  RND     (output) LOGICAL
*          Specifies whether proper rounding  ( RND = .TRUE. )  or
*          chopping  ( RND = .FALSE. )  occurs in addition. This may not
*          be a reliable guide to the way in which the machine performs
*          its arithmetic.
*
*  EPS     (output) DOUBLE PRECISION
*          The smallest positive number such that
*
*             fl( 1.0 - EPS ) .LT. 1.0,
*
*          where fl denotes the computed value.
*
*  EMIN    (output) INTEGER
*          The minimum exponent before (gradual) underflow occurs.
*
*  RMIN    (output) DOUBLE PRECISION
*          The smallest normalized number for the machine, given by
*          BASE**( EMIN - 1 ), where  BASE  is the floating point value
*          of BETA.
*
*  EMAX    (output) INTEGER
*          The maximum exponent before overflow occurs.
*
*  RMAX    (output) DOUBLE PRECISION
*          The largest positive number for the machine, given by
*          BASE**EMAX * ( 1 - EPS ), where  BASE  is the floating point
*          value of BETA.
*
*  Further Details
*  ===============
*
*  The computation of  EPS  is based on a routine PARANOIA by
*  W. Kahan of the University of California at Berkeley.
*
* =====================================================================
*
*     .. Local Scalars ..
      LOGICAL            FIRST, IEEE, IWARN, LIEEE1, LRND
      INTEGER            GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT,
     $                   NGNMIN, NGPMIN
      DOUBLE PRECISION   A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE,
     $                   SIXTH, SMALL, THIRD, TWO, ZERO
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMC3
      EXTERNAL           DLAMC3
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLAMC1, DLAMC4, DLAMC5
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
*     ..
*     .. Save statement ..
      SAVE               FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX,
     $                   LRMIN, LT
*     ..
*     .. Data statements ..
      DATA               FIRST / .TRUE. / , IWARN / .FALSE. /
*     ..
*     .. Executable Statements ..
*
      IF( FIRST ) THEN
         FIRST = .FALSE.
         ZERO = 0
         ONE = 1
         TWO = 2
*
*        LBETA, LT, LRND, LEPS, LEMIN and LRMIN  are the local values of
*        BETA, T, RND, EPS, EMIN and RMIN.
*
*        Throughout this routine  we use the function  DLAMC3  to ensure
*        that relevant values are stored  and not held in registers,  or
*        are not affected by optimizers.
*
*        DLAMC1 returns the parameters  LBETA, LT, LRND and LIEEE1.
*
         CALL DLAMC1( LBETA, LT, LRND, LIEEE1 )
*
*        Start to find EPS.
*
         B = LBETA
         A = B**( -LT )
         LEPS = A
*
*        Try some tricks to see whether or not this is the correct  EPS.
*
         B = TWO / 3
         HALF = ONE / 2
         SIXTH = DLAMC3( B, -HALF )
         THIRD = DLAMC3( SIXTH, SIXTH )
         B = DLAMC3( THIRD, -HALF )
         B = DLAMC3( B, SIXTH )
         B = ABS( B )
         IF( B.LT.LEPS )
     $      B = LEPS
*
         LEPS = 1
*
*+       WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP
   10    CONTINUE
         IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN
            LEPS = B
            C = DLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) )
            C = DLAMC3( HALF, -C )
            B = DLAMC3( HALF, C )
            C = DLAMC3( HALF, -B )
            B = DLAMC3( HALF, C )
            GO TO 10
         END IF
*+       END WHILE
*
         IF( A.LT.LEPS )
     $      LEPS = A
*
*        Computation of EPS complete.
*
*        Now find  EMIN.  Let A = + or - 1, and + or - (1 + BASE**(-3)).
*        Keep dividing  A by BETA until (gradual) underflow occurs. This
*        is detected when we cannot recover the previous A.
*
         RBASE = ONE / LBETA
         SMALL = ONE
         DO 20 I = 1, 3
            SMALL = DLAMC3( SMALL*RBASE, ZERO )
   20    CONTINUE
         A = DLAMC3( ONE, SMALL )
         CALL DLAMC4( NGPMIN, ONE, LBETA )
         CALL DLAMC4( NGNMIN, -ONE, LBETA )
         CALL DLAMC4( GPMIN, A, LBETA )
         CALL DLAMC4( GNMIN, -A, LBETA )
         IEEE = .FALSE.
*
         IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN
            IF( NGPMIN.EQ.GPMIN ) THEN
               LEMIN = NGPMIN
*            ( Non twos-complement machines, no gradual underflow;
*              e.g.,  VAX )
            ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN
               LEMIN = NGPMIN - 1 + LT
               IEEE = .TRUE.
*            ( Non twos-complement machines, with gradual underflow;
*              e.g., IEEE standard followers )
            ELSE
               LEMIN = MIN( NGPMIN, GPMIN )
*            ( A guess; no known machine )
               IWARN = .TRUE.
            END IF
*
         ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN
            IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN
               LEMIN = MAX( NGPMIN, NGNMIN )
*            ( Twos-complement machines, no gradual underflow;
*              e.g., CYBER 205 )
            ELSE
               LEMIN = MIN( NGPMIN, NGNMIN )
*            ( A guess; no known machine )
               IWARN = .TRUE.
            END IF
*
         ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND.
     $            ( GPMIN.EQ.GNMIN ) ) THEN
            IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN
               LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT
*            ( Twos-complement machines with gradual underflow;
*              no known machine )
            ELSE
               LEMIN = MIN( NGPMIN, NGNMIN )
*            ( A guess; no known machine )
               IWARN = .TRUE.
            END IF
*
         ELSE
            LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN )
*         ( A guess; no known machine )
            IWARN = .TRUE.
         END IF
***
* Comment out this if block if EMIN is ok
         IF( IWARN ) THEN
            FIRST = .TRUE.
            WRITE( 6, FMT = 9999 )LEMIN
         END IF
***
*
*        Assume IEEE arithmetic if we found denormalised  numbers above,
*        or if arithmetic seems to round in the  IEEE style,  determined
*        in routine DLAMC1. A true IEEE machine should have both  things
*        true; however, faulty machines may have one or the other.
*
         IEEE = IEEE .OR. LIEEE1
*
*        Compute  RMIN by successive division by  BETA. We could compute
*        RMIN as BASE**( EMIN - 1 ),  but some machines underflow during
*        this computation.
*
         LRMIN = 1
         DO 30 I = 1, 1 - LEMIN
            LRMIN = DLAMC3( LRMIN*RBASE, ZERO )
   30    CONTINUE
*
*        Finally, call DLAMC5 to compute EMAX and RMAX.
*
         CALL DLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX )
      END IF
*
      BETA = LBETA
      T = LT
      RND = LRND
      EPS = LEPS
      EMIN = LEMIN
      RMIN = LRMIN
      EMAX = LEMAX
      RMAX = LRMAX
*
      RETURN
*
 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-',
     $      '  EMIN = ', I8, /
     $      ' If, after inspection, the value EMIN looks',
     $      ' acceptable please comment out ',
     $      / ' the IF block as marked within the code of routine',
     $      ' DLAMC2,', / ' otherwise supply EMIN explicitly.', / )
*
*     End of DLAMC2
*
      END
*

*
************************************************************************
*
      SUBROUTINE DLAMC4( EMIN, START, BASE )
*
*  -- LAPACK auxiliary routine (version 1.1) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     October 31, 1992
*
*     .. Scalar Arguments ..
      INTEGER            BASE, EMIN
      DOUBLE PRECISION   START
*     ..
*
*  Purpose
*  =======
*
*  DLAMC4 is a service routine for DLAMC2.
*
*  Arguments
*  =========
*
*  EMIN    (output) EMIN
*          The minimum exponent before (gradual) underflow, computed by
*          setting A = START and dividing by BASE until the previous A
*          can not be recovered.
*
*  START   (input) DOUBLE PRECISION
*          The starting point for determining EMIN.
*
*  BASE    (input) INTEGER
*          The base of the machine.
*
* =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I
      DOUBLE PRECISION   A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMC3
      EXTERNAL           DLAMC3
*     ..
*     .. Executable Statements ..
*
      A = START
      ONE = 1
      RBASE = ONE / BASE
      ZERO = 0
      EMIN = 1
      B1 = DLAMC3( A*RBASE, ZERO )
      C1 = A
      C2 = A
      D1 = A
      D2 = A
*+    WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND.
*    $       ( D1.EQ.A ).AND.( D2.EQ.A )      )LOOP
   10 CONTINUE
      IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND.
     $    ( D2.EQ.A ) ) THEN
         EMIN = EMIN - 1
         A = B1
         B1 = DLAMC3( A / BASE, ZERO )
         C1 = DLAMC3( B1*BASE, ZERO )
         D1 = ZERO
         DO 20 I = 1, BASE
            D1 = D1 + B1
   20    CONTINUE
         B2 = DLAMC3( A*RBASE, ZERO )
         C2 = DLAMC3( B2 / RBASE, ZERO )
         D2 = ZERO
         DO 30 I = 1, BASE
            D2 = D2 + B2
   30    CONTINUE
         GO TO 10
      END IF
*+    END WHILE
*
      RETURN
*
*     End of DLAMC4
*
      END
*
************************************************************************
*
      SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX )
*
*  -- LAPACK auxiliary routine (version 1.1) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     October 31, 1992
*
*     .. Scalar Arguments ..
      LOGICAL            IEEE
      INTEGER            BETA, EMAX, EMIN, P
      DOUBLE PRECISION   RMAX
*     ..
*
*  Purpose
*  =======
*
*  DLAMC5 attempts to compute RMAX, the largest machine floating-point
*  number, without overflow.  It assumes that EMAX + abs(EMIN) sum
*  approximately to a power of 2.  It will fail on machines where this
*  assumption does not hold, for example, the Cyber 205 (EMIN = -28625,
*  EMAX = 28718).  It will also fail if the value supplied for EMIN is
*  too large (i.e. too close to zero), probably with overflow.
*
*  Arguments
*  =========
*
*  BETA    (input) INTEGER
*          The base of floating-point arithmetic.
*
*  P       (input) INTEGER
*          The number of base BETA digits in the mantissa of a
*          floating-point value.
*
*  EMIN    (input) INTEGER
*          The minimum exponent before (gradual) underflow.
*
*  IEEE    (input) LOGICAL
*          A logical flag specifying whether or not the arithmetic
*          system is thought to comply with the IEEE standard.
*
*  EMAX    (output) INTEGER
*          The largest exponent before overflow
*
*  RMAX    (output) DOUBLE PRECISION
*          The largest machine floating-point number.
*
* =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
*     ..
*     .. Local Scalars ..
      INTEGER            EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP
      DOUBLE PRECISION   OLDY, RECBAS, Y, Z
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMC3
      EXTERNAL           DLAMC3
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MOD
*     ..
*     .. Executable Statements ..
*
*     First compute LEXP and UEXP, two powers of 2 that bound
*     abs(EMIN). We then assume that EMAX + abs(EMIN) will sum
*     approximately to the bound that is closest to abs(EMIN).
*     (EMAX is the exponent of the required number RMAX).
*
      LEXP = 1
      EXBITS = 1
   10 CONTINUE
      TRY = LEXP*2
      IF( TRY.LE.( -EMIN ) ) THEN
         LEXP = TRY
         EXBITS = EXBITS + 1
         GO TO 10
      END IF
      IF( LEXP.EQ.-EMIN ) THEN
         UEXP = LEXP
      ELSE
         UEXP = TRY
         EXBITS = EXBITS + 1
      END IF
*
*     Now -LEXP is less than or equal to EMIN, and -UEXP is greater
*     than or equal to EMIN. EXBITS is the number of bits needed to
*     store the exponent.
*
      IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN
         EXPSUM = 2*LEXP
      ELSE
         EXPSUM = 2*UEXP
      END IF
*
*     EXPSUM is the exponent range, approximately equal to
*     EMAX - EMIN + 1 .
*
      EMAX = EXPSUM + EMIN - 1
      NBITS = 1 + EXBITS + P
*
*     NBITS is the total number of bits needed to store a
*     floating-point number.
*
      IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN
*
*        Either there are an odd number of bits used to store a
*        floating-point number, which is unlikely, or some bits are
*        not used in the representation of numbers, which is possible,
*        (e.g. Cray machines) or the mantissa has an implicit bit,
*        (e.g. IEEE machines, Dec Vax machines), which is perhaps the
*        most likely. We have to assume the last alternative.
*        If this is true, then we need to reduce EMAX by one because
*        there must be some way of representing zero in an implicit-bit
*        system. On machines like Cray, we are reducing EMAX by one
*        unnecessarily.
*
         EMAX = EMAX - 1
      END IF
*
      IF( IEEE ) THEN
*
*        Assume we are on an IEEE machine which reserves one exponent
*        for infinity and NaN.
*
         EMAX = EMAX - 1
      END IF
*
*     Now create RMAX, the largest machine number, which should
*     be equal to (1.0 - BETA**(-P)) * BETA**EMAX .
*
*     First compute 1.0 - BETA**(-P), being careful that the
*     result is less than 1.0 .
*
      RECBAS = ONE / BETA
      Z = BETA - ONE
      Y = ZERO
      DO 20 I = 1, P
         Z = Z*RECBAS
         IF( Y.LT.ONE )
     $      OLDY = Y
         Y = DLAMC3( Y, Z )
   20 CONTINUE
      IF( Y.GE.ONE )
     $   Y = OLDY
*
*     Now multiply by BETA**EMAX to get RMAX.
*
      DO 30 I = 1, EMAX
         Y = DLAMC3( Y*BETA, ZERO )
   30 CONTINUE
*
      RMAX = Y
      RETURN
*
*     End of DLAMC5
*
      END


Subroutine luzdis(kfl1, kfl2, pr, z)
  Common /ludat1/mstu(200), paru(200), mstj(200), parj(200)
  Save /ludat1/
  kfla = iabs(kfl1)
  kflb = iabs(kfl2)
  kflh = kfla
  If (kfla>=10) kflh = mod(kfla/1000, 10)
  If (mstj(11)==1 .Or. (mstj(11)==3 .And. kflh<=3)) Then
    fa = parj(41)
    If (mstj(91)==1) fa = parj(43)
    If (kflb>=10) fa = fa + parj(45)
    fb = parj(42)*pr
    If (mstj(91)==1) fb = parj(44)*pr
    fc = 1.
    If (kfla>=10) fc = fc - parj(45)
    If (kflb>=10) fc = fc + parj(45)
    mc = 1
    If (abs(fc-1.)>0.01) mc = 2
    If (fa<0.02) Then
      ma = 1
      zmax = 1.
      If (fc>fb) zmax = fb/fc
    Else If (abs(fc-fa)<0.01) Then
      ma = 2
      zmax = fb/(fb+fc)
    Else
      ma = 3
      zmax = 0.5*(fb+fc-sqrt((fb-fc)**2+4.*fa*fb))/(fc-fa)
      If (zmax>0.99 .And. fb>100.) zmax = 1. - fa/fb
    End If
    mmax = 2
    If (zmax<0.1) Then
      mmax = 1
      zdiv = 2.75*zmax
      If (mc==1) Then
        fint = 1. - log(zdiv)
      Else
        zdivc = zdiv**(1.-fc)
        fint = 1. + (1.-1./zdivc)/(fc-1.)
      End If
    Else If (zmax>0.85 .And. fb>1.) Then
      mmax = 3
      fscb = sqrt(4.+(fc/fb)**2)
      zdiv = fscb - 1./zmax - (fc/fb)*log(zmax*0.5*(fscb+fc/fb))
      If (ma>=2) zdiv = zdiv + (fa/fb)*log(1.-zmax)
      zdiv = min(zmax, max(0.,zdiv))
      fint = 1. + fb*(1.-zdiv)
    End If
    100 z = rlu(0)
    fpre = 1.
    If (mmax==1) Then
      If (fint*rlu(0)<=1.) Then
        z = zdiv*z
      Else If (mc==1) Then
        z = zdiv**z
        fpre = zdiv/z
      Else
        z = 1./(zdivc+z*(1.-zdivc))**(1./(1.-fc))
        fpre = (zdiv/z)**fc
      End If
    Else If (mmax==3) Then
      If (fint*rlu(0)<=1.) Then
        z = zdiv + log(z)/fb
        fpre = exp(fb*(z-zdiv))
      Else
        z = zdiv + z*(1.-zdiv)
      End If
    End If
    If (z<=fb/(50.+fb) .Or. z>=1.) Goto 100
    fval = (zmax/z)**fc*exp(fb*(1./zmax-1./z))
    If (ma>=2) fval = ((1.-z)/(1.-zmax))**fa*fval
    If (fval<rlu(0)*fpre) Goto 100
  Else
    fc = parj(50+max(1,kflh))
    If (mstj(91)==1) fc = parj(59)
    110 z = rlu(0)
    If (fc>=0. .And. fc<=1.) Then
      If (fc>rlu(0)) z = 1. - z**(1./3.)
    Else If (fc>-1.) Then
      If (-4.*fc*z*(1.-z)**2<rlu(0)*((1.-z)**2-fc*z)**2) Goto 110
    Else
      If (fc>0.) z = 1. - z**(1./fc)
      If (fc<0.) z = z**(-1./fc)
    End If
  End If
  Return
End Subroutine luzdis


submodule(euler_interface_m) euler_prob_0005_m
    implicit none

contains

    module character(len=20) function euler0005()
        write (euler0005, "(i20)") answer(20_int64)
    end function euler0005

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

        ret = 1_int64
        do i = 1_int64, n
            ret = lcm(ret, i)
        end do
    end function answer

end submodule euler_prob_0005_m


      Program numerals
      USE parameters, only: debugMode
      implicit none

      integer(kind=2) :: Number_1, Number_2, NumberSum
      character(LEN=20) :: command_line_argument_1, command_line_argument_2
      character(LEN=:), allocatable :: Numeral_1, Numeral_2, NumeralSum

      ! -----------------------  Initializations
      Number_1 = 0; Number_2 = 0
      ! -------------------------------------------^^^

      CALL GET_COMMAND_ARGUMENT(1, command_line_argument_1)   ! Read argument #1
      CALL GET_COMMAND_ARGUMENT(2, command_line_argument_2)   ! and #2 from the command line, and assign it to comm_arg#

      ! -----------------------
      ! This program takes the user input of two Roman Numerals and produces and outputs the sum as a Numeral
      ! The valid Numeral values are I, V, X, L, C, D, and M and their lowercase
      ! Invalid input includes all other ASCII characters.

      CALL BUFFER_TO_STRING(command_line_argument_1, Numeral_1)   ! Adjust to the left and trim trailing spaces from the string
      CALL CHECK_VALIDITY(Numeral_1)   ! Check the input for invalid ASCII characters, return true or STOP the program

      CALL BUFFER_TO_STRING(command_line_argument_2, Numeral_2)   ! Adjust to the left and trim trailing spaces from the string
      CALL CHECK_VALIDITY(Numeral_2)   ! Check the input for invalid ASCII characters, return true or STOP the program

      Number_1 = DECODER(Numeral_1)
      Number_2 = DECODER(Numeral_2)

      NumberSum = Number_1 + Number_2

      IF (debugMode.eq..TRUE.) WRITE(*,*) Number_1, Number_2, NumberSum

      NumeralSum = ROMAN(NumberSum)

      WRITE(*,*) NumeralSum

      CONTAINS

      !==================================================================================================================
      ! This routine tests whether the input string contains any invalid ASCII characters

      SUBROUTINE CHECK_VALIDITY(StringValue)
      USE PARAMETERS, only: ValidCharacters
      implicit none
      character(LEN=*), intent(in) :: StringValue
      logical                      :: isCharacterValid
      integer                      :: i, j

      DO i = 1, LEN(StringValue)            ! for each character in the input string
         DO j = 1, SIZE(ValidCharacters)    ! for each variable in ValidCharacters
           IF (StringValue(i:i).eq.ValidCharacters(j)) THEN  ! when a match is detected, EXIT the loop and start the next one.
              isCharacterValid = .TRUE.
              EXIT
           ELSE
              isCharacterValid = .FALSE.
           END IF
         END DO
      END DO

      IF (isCharacterValid.eq..FALSE.) THEN
        WRITE(*,*) 'ERROR: ',StringValue, ' contains invalid ASCII characters.'
        STOP
      END IF

      end SUBROUTINE CHECK_VALIDITY
      !==================================================================================================================

      !==================================================================================================================
      ! This routine adjusts the string to the left, removes any trailing spaces, and allocates the new length.
      ! The resulting string cannot be empty.

      SUBROUTINE BUFFER_TO_STRING(buffer, StringValue)
      implicit none
      character(LEN=20)            , intent(in)  :: buffer
      character(LEN=:), allocatable, intent(out) :: StringValue

      StringValue = trim(adjustL(buffer))

      IF (StringValue.eq.'') THEN
        WRITE(*,*) 'ERROR: command line argument empty.'
        STOP
      ENDIF

      end SUBROUTINE BUFFER_TO_STRING
      !==================================================================================================================

      !==================================================================================================================
      !SOURCE: https://rosettacode.org/wiki/Roman_numerals/Encode#Fortran
      ! This function takes the input of a number and translates it in a valid Roman Numeral

      FUNCTION ROMAN(numberArabic) RESULT (numeral)
      USE PARAMETERS, only: RomanNumberValues, numeralCharacters
      implicit none
      integer(kind=2), intent(in) :: numberArabic
      integer                     :: i, numberDummy, integerDivision
      character(32)               :: numeral

      numeral = ''                                      ! initialise the string to null
      numberDummy = numberArabic                        ! use numberDummy to store the changing number instead of numberArabic(intent(in))

      DO i = 1, SIZE(RomanNumberValues)                 ! for every distinct roman numeral number, descending order (high to low)
        integerDivision = numberDummy / RomanNumberValues(i)                  ! divide number over largest integer, store result
        numeral = trim(numeral) // repeat(trim(numeralCharacters(i)), integerDivision)     ! collate numeral characters integerDivision times
        numberDummy = numberDummy - RomanNumberValues(i) * integerDivision    ! subtract the value integerDivision times, and update
      END DO

      END FUNCTION ROMAN
      !==================================================================================================================

      !==================================================================================================================
      !SOURCE: https://www.rosettacode.org/wiki/Roman_numerals/DECODE#Fortran
      !The original version cannot understand invalid numeral progression. F.e. it can be fooled by IVIVIVI, IXI-IVI, CMCMDIXVIXVID, etc
      !
      FUNCTION DECODER(numeral) RESULT(numberArabic)
      implicit none
      character(LEN=*), intent(in)   :: numeral
      integer                        :: i, newValue, previousValue, numberArabic
      integer(kind=2), dimension(13) :: counters
      logical                        :: isDoubleValueNumeral

      !----- Initialisation --------------------------------
      numberArabic = 0
      previousValue = 0
      isDoubleValueNumeral = .FALSE.
      newValue = 0
      counters = 0
      !-----------------------------------------------------

      DO i = LEN(numeral), 1, -1                                          ! Start from the end and iterate the opposite way
        IF (isDoubleValueNumeral.eq..TRUE.) THEN                          ! IF the previous iteration numeral is part of double value numeral
          isDoubleValueNumeral = .FALSE.                                  ! RESET the trigger AND
          CYCLE                                                           ! skip the current loop
        END IF

        SELECT CASE(numeral(i:i))
        CASE ('M','m')                                                    ! IF the numeral is M
          newValue = 1000                                                 ! update newValue
          CALL COUNTING(13,counters)                                      ! increase M counter by 1
          IF (i.ne.1) THEN                                                ! IF the numeral is not the last one
            IF (numeral(i-1:i-1).eq.'C'.or.numeral(i-1:i-1).eq.'c') THEN  ! IF the numeral before forms CAN form a double value numeral
              newValue = 900                                              ! update newValue by overwriting the previous
              isDoubleValueNumeral = .TRUE.                               ! the two numerals of i and i-1 form a double value numeral
              CALL COUNTING(12,counters)                                  ! increase CM counter by 1
              IF (counters(9).ge.counters(12)) THEN                       ! IF the i-1 component of the numeral coexists with the individual numeral character
                WRITE(*,*) 'ERROR: INVALID NUMERAL SUCCESSION. CM and C found together.'
                STOP                                                      ! STOP the program
              END IF
              counters(13) = counters(13) - 1                             ! IF the numeral was a double value numeral, decrease M counter by 1
            END IF
          END IF

        CASE ('D','d')
          newValue = 500
          CALL COUNTING(11,counters)                                      ! increase counter of D
          IF (i.ne.1) THEN
            IF (numeral(i-1:i-1).eq.'C'.or.numeral(i-1:i-1).eq.'c') THEN  ! distinguish CD as 400
              newValue = 400
              isDoubleValueNumeral = .TRUE.
              CALL COUNTING(10,counters)                                  ! increase counter of CD
              IF (counters(9).ge.counters(10)) THEN
                WRITE(*,*) 'ERROR: INVALID NUMERAL SUCCESSION. CD and C found together.'
                STOP
              END IF
              counters(11) = counters(11) - 1
            END IF
          END IF

        CASE ('C','c')
          newValue = 100
          CALL COUNTING(9,counters)                                       ! increase counter of C
          IF (i.ne.1) THEN
            IF (numeral(i-1:i-1).eq.'X'.or.numeral(i-1:i-1).eq.'x') THEN  ! distinguish XC as 90
              newValue = 90
              isDoubleValueNumeral = .TRUE.
              CALL COUNTING(8,counters)                                   ! increase counter of XC
              IF (counters(5).ge.counters(8)) THEN
                WRITE(*,*) 'ERROR: INVALID NUMERAL SUCCESSION. XC and X found together.'
                STOP
              END IF
              counters(9) = counters(9) - 1
            END IF
          END IF

        CASE ('L','l')
          newValue = 50
          CALL COUNTING(7,counters)                                       ! increase counter of L
          IF (i.ne.1) THEN
            IF (numeral(i-1:i-1).eq.'X'.or.numeral(i-1:i-1).eq.'x') THEN  ! distinguish XL as 40
              newValue = 40
              isDoubleValueNumeral = .TRUE.
              CALL COUNTING(6,counters)                                   ! increase counter of XL
              IF (counters(5).ge.counters(6)) THEN
                WRITE(*,*) 'ERROR: INVALID NUMERAL SUCCESSION. XL and X found together.'
                STOP
              END IF
              counters(7) = counters(7) - 1
            END IF
          END IF

        CASE ('X','x')
          newValue = 10
          CALL COUNTING(5,counters)                                       ! increase counter of X

          IF (i.ne.1) THEN
            IF (numeral(i-1:i-1).eq.'I'.or.numeral(i-1:i-1).eq.'i') THEN  ! distinguish IX as 9
              newValue = 9
              isDoubleValueNumeral = .TRUE.
              CALL COUNTING(4,counters)                                   ! increase counter of IX
              IF (counters(1).ge.counters(4)) THEN
                WRITE(*,*) 'ERROR: INVALID NUMERAL SUCCESSION. I and IX found together.'
                STOP
              END IF
              counters(5) = counters(5) - 1
            END IF
          END IF

        CASE ('V','v')
          newValue = 5
          CALL COUNTING(3,counters)                                       ! increase counter of V(lad)

          IF (i.ne.1) THEN
            IF (numeral(i-1:i-1).eq.'I'.or.numeral(i-1:i-1).eq.'i') THEN  ! distinguish IV as 4
              newValue = 4
              isDoubleValueNumeral = .TRUE.
              CALL COUNTING(2, counters)                                  ! increase counter of IV
              IF (counters(1).ge.counters(2)) THEN
                WRITE(*,*) 'ERROR: INVALID NUMERAL SUCCESSION. I and IV found together.'
                STOP
              END IF
              counters(3) = counters(3) - 1
            END IF
          END IF

        CASE ('I','i')
          newValue = 1
          CALL COUNTING(1,counters)                                       ! increase counter of I

        CASE default                                                      ! this will not detect invalid characters
          WRITE(*,*) 'ERROR: SELECT CASE selector wrong value...'
          newValue = 0
        END SELECT

        IF (newValue >= previousValue) THEN                               ! update the number by the newValue if it's equal or larger than the previousValue.
          numberArabic = numberArabic + newValue

          IF (real(previousValue).eq.real(newValue)*4/9) THEN             ! IF the new value is the second double Value Numeral in succession, STOP the program.
            WRITE(*,*) 'INVALID NUMERAL SUCCESSION. Two double value numerals in succession'
            STOP
          END IF

          IF (isDoubleValueNumeral.eq..TRUE..and.real(newValue).lt.real(previousValue*2)) THEN  ! IF newValue is a double value numeral AND less than double of the previousValue...
            WRITE(*,*) 'INVALID NUMERAL SUCCESSION. Double value numeral along with smaller numeral of the same order'
            STOP  ! ...STOP the program. This traps double value numerals followed by smaller numerals, which their sum would be assigned a larger value numeral (eg IXV = 9+5 = 14 = XIV)
          END IF

        ELSE                                                              ! IF newValue < previousValue
          WRITE(*,*) 'INVALID NUMERAL SUCCESSION'
          STOP
        END IF

        previousValue = newValue                                          ! update the previous value in preparation of next iteration
      END DO
      END FUNCTION DECODER
      !==================================================================================================================

      !==================================================================================================================
      ! This routine iterates the counters for each roman numeral, and compares the amount to the valid count. If the
      ! count is larger than the valid count, the program STOPs.

      SUBROUTINE COUNTING(order,counters)
      USE PARAMETERS, only: validCount            ! total valid amount of counts for each numeral
      implicit none
      integer(kind=2), intent(in) :: order       ! the order is given by the numeral succession: I, IV, V, IX, X, .. etc
      integer(kind=2), dimension(13), intent(inout) :: counters    ! how many counts of each numeral are triggered

      counters(order) = counters(order) + 1     ! iterate for every call
      IF (counters(order).gt.validCount(order)) THEN  ! if more counts than permitted are found, abort the program with an error.
        WRITE(*,*) 'ERROR: INVALID NUMERAL COUNT. MULTIPLES FOUND.'
        STOP
      END IF

      end SUBROUTINE COUNTING
      !==================================================================================================================

      end program numerals


!
!
  PROGRAM SH
!+++++++++++++++++++++++++++++++++++++++
!
! Builds a table of spherical harmonics
! DM April 18, 2019
! based on 'SHA-REV1.F90', GS June 15, 2016
!
!+++++++++++++++++++++++++++++++++++++++
  implicit NONE
!
  INTEGER :: RES
  INTEGER :: NP
  INTEGER :: LMAX
  INTEGER :: JMAX
  CHARACTER*72 :: PXFILE
  CHARACTER*72 :: PLFILE
  CHARACTER*72 :: SHFILE
  CHARACTER*200 :: BUFFER
  CHARACTER*20   :: CHR, CHL
!
  INTEGER, PARAMETER :: A_LARGE_INTEGER=10**6
!
  INTEGER I, J, K, L, NA
  REAL*8 COSDD, SINDD, LATA, LONG
  REAL*8,     DIMENSION (:,:), ALLOCATABLE:: ALF
  COMPLEX*16, DIMENSION (:,:), ALLOCATABLE:: LONG_TABLE
  REAL*8, ALLOCATABLE :: LON(:), LAT(:)
  REAL*8  JUNK
!
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!
! --- Examining command-line arguments
!
  if( (iargc().ne.2) .and. (iargc().ne.3) .and. (iargc().ne.4) .and. (iargc().ne.5) ) then
     write (*,*)
     write (*,*) "USAGE: sha.exe RES LMAX <px-file> <pxlat-file> <sh-file>"
     write (*,*)
     write (*,*) "  RES                  Tegmark resolution"
     write (*,*) "  LMAX                 Maximum harmonic degree"
     write (*,*) "  px-file, pxlat-file  Files with pixels and main latitudes."
     write (*,*) "                         (if not specified, the default is "
     write (*,*) "                          px-Rnn.dat and px-lat-Rnn.dat )"
     write (*,*) "  sh-file              Output file with ALFs and TRIGs."
     write (*,*) "                         (if not specified, the default is "
     write (*,*) "                          sh-RnnLnn.dat)"
     write (*,*)
     stop
  end if
!
  call getarg(1,buffer)   ; read(buffer,*) res
  call getarg(2,buffer)   ; read(buffer,*) lmax
!
  write(chr,*) res  ; chr=adjustl(chr)
  write(chl,*) lmax ; chl=adjustl(chl)
!
  if( iargc().eq.2 ) then         ! No file is specified
      pxfile = 'px-R'//trim(chr)//'.dat'
      plfile = 'px-lat-R'//trim(chr)//'.dat'
      shfile='sh-R'//trim(chr)//'L'//trim(chl)//'.bin'
  elseif( iargc().eq.3 ) then     ! Only the output file is specified
      call getarg(3,shfile)
      pxfile = 'px-R'//trim(chr)//'.dat'
      plfile = 'px-lat-R'//trim(chr)//'.dat'
  elseif( iargc().eq.4 ) then     ! Only the pixel files are specified
      call getarg(3,pxfile)
      call getarg(4,plfile)
      shfile='sh-R'//trim(chr)//'L'//trim(chl)//'.bin'
  elseif( iargc().eq.5 ) then     ! All files are specified
      call getarg(3,pxfile)
      call getarg(4,plfile)
      call getarg(5,shfile)
  else
      write(*,*) ' Wrong number of arguments ! '
      stop
  end if
!
  NP=2*RES*(RES-1)*20+12
  JMAX=(LMAX+1)*(LMAX+2)/2
!
!
!
!
  write(*,*)" ---- Maximum degree: ", lmax
  write(*,*)" ---- Resolution: ", res
  write(*,*)" ---- Number of pixels: ", np
!
!
  write(*,*) " ---- Reading pixels data from file: ", trim(adjustl(PXFILE))
  open(10,file=PXFILE,status="old")
  do i=1,np
     read(10,*) junk, junk, na
  end do
  close(10)
  Write(*,*) " ---- Number of MAIN pixels: ", NA
!
  ALLOCATE(LAT(NA))
!
  write(*,*) " ---- Reading pixels data from file: ", trim(adjustl(PLFILE))
  open(10,file=PLFILE,status="old")
  do i=1,na
     read(10,*) junk, lat(i)
  end do
  close(10)
!
  ALLOCATE(LON(NP))
  write(*,*) " ---- Reading longitude data"
  open(10,file=PXFILE,status="old")
  do i=1,np
     read(10,*) lon(i)
  end do
  close(10)
!
!
!
  write(*,*) " ---- Opening file: ", trim(adjustl(SHFILE))
  open(20,file=SHFILE,status='unknown',form='unformatted')
!
!
  Write(*,*) " ---- Pre-computing ALFs at latitudes of anchor pixels"
  ALLOCATE(ALF(JMAX,NA))
!
! +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
! CAUTION! PLMBAR_MOD pre-computes some expressions each time it is
! called with a new lmax and stores them in a SAVEd array for reuse
! in subsequent calls. This is thread-safe IF and ONLY IF (1) plmbar_mod
! is called BEFORE the parallel region and (2) all the calls in the
! parallel region use the same lmax.
! +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!
  Write(*,*) " ---- First call to PLMBAR_MOD"
  call PLMBAR_MOD( lmax, lat(1), ALF(:,1) )
  Write(*,*) " ---- Other calls"
!
!$OMP PARALLEL DEFAULT(PRIVATE) SHARED(NA,ALF,LAT,LMAX)
!$OMP DO SCHEDULE(GUIDED)
  do i=2, na
     if(mod(i,5000)==0)write(*,*) i, " of ", na
     lata = lat(i)
     call PLMBAR_MOD (lmax, lata, ALF(:,i))
  enddo
!$OMP END PARALLEL
!
  write(*,*) " ---- Writing the Legendre functions on file: ", trim(adjustl(SHFILE))
  WRITE(20) ALF
  DEALLOCATE(ALF)
!
!
  Write(*,*) " ---- Pre-computing TRIG functions at pixels"
  ALLOCATE(LONG_TABLE(0:LMAX,NP))
!
!$OMP PARALLEL DO DEFAULT(PRIVATE) SHARED(LONG_TABLE,LON,NP,LMAX) SCHEDULE(GUIDED)
  do i=1, np
     long = lon(i)
     do l=0, lmax
	  long_table(l,i)=cmplx(cosdd(l*long),sindd(l*long))
     enddo
  enddo
!$OMP END PARALLEL DO
!
  write(*,*) " ---- Writing the sines and cosines on file: ", trim(adjustl(SHFILE))
  WRITE(20) LONG_TABLE
  DEALLOCATE(LONG_TABLE)
!
  CLOSE(20)
!
  DEALLOCATE(LON)
  DEALLOCATE(LAT)
!
!
 write(*,*) " ***************************************************** "
 write(*,*) " - Copy or better move the following file into ../DATA "
 write(*,*) trim(adjustl(SHFILE))
 write(*,*) " ***************************************************** "
 write(*,*) " Thank you!"
!
!
  end program SH
!
!
!