C-----------------------------------------------------------------------
      SUBROUTINE POLATEV0(IPOPT,KGDSI,KGDSO,MI,MO,KM,IBI,LI,UI,VI,
     &                    NO,RLAT,RLON,CROT,SROT,IBO,LO,UO,VO,IRET)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:  POLATEV0   INTERPOLATE VECTOR FIELDS (BILINEAR)
C   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-04-10
C
C ABSTRACT: THIS SUBPROGRAM PERFORMS BILINEAR INTERPOLATION
C           FROM ANY GRID TO ANY GRID FOR VECTOR FIELDS.
C           OPTIONS ALLOW VARYING THE MINIMUM PERCENTAGE FOR MASK,
C           I.E. PERCENT VALID INPUT DATA REQUIRED TO MAKE OUTPUT DATA,
C           (IPOPT(1)) WHICH DEFAULTS TO 50 (IF IPOPT(1)=-1).
C           ONLY HORIZONTAL INTERPOLATION IS PERFORMED.
C           THE GRIDS ARE DEFINED BY THEIR GRID DESCRIPTION SECTIONS
C           (PASSED IN INTEGER FORM AS DECODED BY SUBPROGRAM W3FI63).
C           THE CURRENT CODE RECOGNIZES THE FOLLOWING PROJECTIONS:
C             (KGDS(1)=000) EQUIDISTANT CYLINDRICAL
C             (KGDS(1)=001) MERCATOR CYLINDRICAL
C             (KGDS(1)=003) LAMBERT CONFORMAL CONICAL
C             (KGDS(1)=004) GAUSSIAN CYLINDRICAL (SPECTRAL NATIVE)
C             (KGDS(1)=005) POLAR STEREOGRAPHIC AZIMUTHAL
C             (KGDS(1)=202) ROTATED EQUIDISTANT CYLINDRICAL (ETA NATIVE)
C           WHERE KGDS COULD BE EITHER INPUT KGDSI OR OUTPUT KGDSO.
C           THE INPUT AND OUTPUT VECTORS ARE ROTATED SO THAT THEY ARE
C           EITHER RESOLVED RELATIVE TO THE DEFINED GRID
C           IN THE DIRECTION OF INCREASING X AND Y COORDINATES
C           OR RESOLVED RELATIVE TO EASTERLY AND NORTHERLY DIRECTIONS,
C           AS DESIGNATED BY THEIR RESPECTIVE GRID DESCRIPTION SECTIONS.
C           AS AN ADDED BONUS THE NUMBER OF OUTPUT GRID POINTS
C           AND THEIR LATITUDES AND LONGITUDES ARE ALSO RETURNED
C           ALONG WITH THEIR VECTOR ROTATION PARAMETERS.
C           ON THE OTHER HAND, THE OUTPUT CAN BE A SET OF STATION POINTS
C           IF KGDSO(1)<0, IN WHICH CASE THE NUMBER OF POINTS
C           AND THEIR LATITUDES AND LONGITUDES MUST BE INPUT
C           ALONG WITH THEIR VECTOR ROTATION PARAMETERS.
C           INPUT BITMAPS WILL BE INTERPOLATED TO OUTPUT BITMAPS.
C           OUTPUT BITMAPS WILL ALSO BE CREATED WHEN THE OUTPUT GRID
C           EXTENDS OUTSIDE OF THE DOMAIN OF THE INPUT GRID.
C           THE OUTPUT FIELD IS SET TO 0 WHERE THE OUTPUT BITMAP IS OFF.
C
C PROGRAM HISTORY LOG:
C   96-04-10  IREDELL
C 1999-04-08  IREDELL  SPLIT IJKGDS INTO TWO PIECES
C 2001-06-18  IREDELL  INCLUDE MINIMUM MASK PERCENTAGE OPTION
C 2002-01-17  IREDELL  SAVE DATA FROM LAST CALL FOR OPTIMIZATION
C 2007-05-22  IREDELL  EXTRAPOLATE UP TO HALF A GRID CELL
C 2007-10-30  IREDELL  SAVE WEIGHTS AND THREAD FOR PERFORMANCE
C
C USAGE:    CALL POLATEV0(IPOPT,KGDSI,KGDSO,MI,MO,KM,IBI,LI,UI,VI,
C    &                    NO,RLAT,RLON,CROT,SROT,IBO,LO,UO,VO,IRET)
C
C   INPUT ARGUMENT LIST:
C     IPOPT    - INTEGER (20) INTERPOLATION OPTIONS
C                IPOPT(1) IS MINIMUM PERCENTAGE FOR MASK
C                (DEFAULTS TO 50 IF IPOPT(1)=-1)
C     KGDSI    - INTEGER (200) INPUT GDS PARAMETERS AS DECODED BY W3FI63
C     KGDSO    - INTEGER (200) OUTPUT GDS PARAMETERS
C                (KGDSO(1)<0 IMPLIES RANDOM STATION POINTS)
C     MI       - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS IF KM>1
C                OR DIMENSION OF INPUT GRID FIELDS IF KM=1
C     MO       - INTEGER SKIP NUMBER BETWEEN OUTPUT GRID FIELDS IF KM>1
C                OR DIMENSION OF OUTPUT GRID FIELDS IF KM=1
C     KM       - INTEGER NUMBER OF FIELDS TO INTERPOLATE
C     IBI      - INTEGER (KM) INPUT BITMAP FLAGS
C     LI       - LOGICAL*1 (MI,KM) INPUT BITMAPS (IF SOME IBI(K)=1)
C     UI       - REAL (MI,KM) INPUT U-COMPONENT FIELDS TO INTERPOLATE
C     VI       - REAL (MI,KM) INPUT V-COMPONENT FIELDS TO INTERPOLATE
C     NO       - INTEGER NUMBER OF OUTPUT POINTS (ONLY IF KGDSO(1)<0)
C     RLAT     - REAL (NO) OUTPUT LATITUDES IN DEGREES (IF KGDSO(1)<0)
C     RLON     - REAL (NO) OUTPUT LONGITUDES IN DEGREES (IF KGDSO(1)<0)
C     CROT     - REAL (NO) VECTOR ROTATION COSINES (IF KGDSO(1)<0)
C     SROT     - REAL (NO) VECTOR ROTATION SINES (IF KGDSO(1)<0)
C                (UGRID=CROT*UEARTH-SROT*VEARTH;
C                 VGRID=SROT*UEARTH+CROT*VEARTH)
C
C   OUTPUT ARGUMENT LIST:
C     NO       - INTEGER NUMBER OF OUTPUT POINTS (ONLY IF KGDSO(1)>=0)
C     RLAT     - REAL (MO) OUTPUT LATITUDES IN DEGREES (IF KGDSO(1)>=0)
C     RLON     - REAL (MO) OUTPUT LONGITUDES IN DEGREES (IF KGDSO(1)>=0)
C     CROT     - REAL (NO) VECTOR ROTATION COSINES (IF KGDSO(1)>=0)
C     SROT     - REAL (NO) VECTOR ROTATION SINES (IF KGDSO(1)>=0)
C                (UGRID=CROT*UEARTH-SROT*VEARTH;
C                 VGRID=SROT*UEARTH+CROT*VEARTH)
C     IBO      - INTEGER (KM) OUTPUT BITMAP FLAGS
C     LO       - LOGICAL*1 (MO,KM) OUTPUT BITMAPS (ALWAYS OUTPUT)
C     UO       - REAL (MO,KM) OUTPUT U-COMPONENT FIELDS INTERPOLATED
C     VO       - REAL (MO,KM) OUTPUT V-COMPONENT FIELDS INTERPOLATED
C     IRET     - INTEGER RETURN CODE
C                0    SUCCESSFUL INTERPOLATION
C                2    UNRECOGNIZED INPUT GRID OR NO GRID OVERLAP
C                3    UNRECOGNIZED OUTPUT GRID
C
C SUBPROGRAMS CALLED:
C   GDSWIZ       GRID DESCRIPTION SECTION WIZARD
C   IJKGDS0      SET UP PARAMETERS FOR IJKGDS1
C   (IJKGDS1)    RETURN FIELD POSITION FOR A GIVEN GRID POINT
C   (MOVECT)     MOVE A VECTOR ALONG A GREAT CIRCLE
C   POLFIXV      MAKE MULTIPLE POLE VECTOR VALUES CONSISTENT
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C
C$$$
      IMPLICIT NONE
      INTEGER,INTENT(IN):: IPOPT(20),KGDSI(200),KGDSO(200),MI,MO,KM
      INTEGER,INTENT(IN):: IBI(KM)
      LOGICAL*1,INTENT(IN):: LI(MI,KM)
      REAL,INTENT(IN):: UI(MI,KM),VI(MI,KM)
      INTEGER,INTENT(INOUT):: NO
      REAL,INTENT(INOUT):: RLAT(MO),RLON(MO),CROT(MO),SROT(MO)
      INTEGER,INTENT(OUT):: IBO(KM)
      LOGICAL*1,INTENT(OUT):: LO(MO,KM)
      REAL,INTENT(OUT):: UO(MO,KM),VO(MO,KM)
      INTEGER,INTENT(OUT):: IRET
      REAL XPTS(MO),YPTS(MO)
      INTEGER IJX(2),IJY(2)
      REAL WX(2),WY(2)
      INTEGER IJKGDSA(20)
      REAL,PARAMETER:: FILL=-9999.
      INTEGER MP,N,I,J,K,NK,NV,IJKGDS1
      REAL PMP,XIJ,YIJ,XF,YF,U,V,W,DUM
      REAL XPTI(MI),YPTI(MI),RLOI(MI),RLAI(MI),CROI(MI),SROI(MI)
      REAL CM,SM,UROT,VROT
      INTEGER,SAVE:: KGDSIX(200)=-1,KGDSOX(200)=-1,NOX=-1,IRETX=-1
      INTEGER,ALLOCATABLE,SAVE:: NXY(:,:,:)
      REAL,ALLOCATABLE,SAVE:: RLATX(:),RLONX(:),CROTX(:),SROTX(:)
      REAL,ALLOCATABLE,SAVE:: WXY(:,:,:),CXY(:,:,:),SXY(:,:,:)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  SET PARAMETERS
      IRET=0
      MP=IPOPT(1)
      IF(MP.EQ.-1.OR.MP.EQ.0) MP=50
      IF(MP.LT.0.OR.MP.GT.100) IRET=32
      PMP=MP*0.01
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  SAVE OR SKIP WEIGHT COMPUTATION
      IF(IRET.EQ.0.AND.(KGDSO(1).LT.0.OR.
     &    ANY(KGDSI.NE.KGDSIX).OR.ANY(KGDSO.NE.KGDSOX))) THEN
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  COMPUTE NUMBER OF OUTPUT POINTS AND THEIR LATITUDES AND LONGITUDES.
        IF(KGDSO(1).GE.0) THEN
          CALL GDSWIZ(KGDSO, 0,MO,FILL,XPTS,YPTS,RLON,RLAT,NO,
     &                1,CROT,SROT)
          IF(NO.EQ.0) IRET=3
        ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  LOCATE INPUT POINTS
        CALL GDSWIZ(KGDSI,-1,NO,FILL,XPTS,YPTS,RLON,RLAT,NV,0,DUM,DUM)
        IF(IRET.EQ.0.AND.NV.EQ.0) IRET=2
        CALL GDSWIZ(KGDSI, 0,MI,FILL,XPTI,YPTI,RLOI,RLAI,NV,1,CROI,SROI)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  ALLOCATE AND SAVE GRID DATA
        KGDSIX=KGDSI
        KGDSOX=KGDSO
        IF(NOX.NE.NO) THEN
          IF(NOX.GE.0) DEALLOCATE(RLATX,RLONX,CROTX,SROTX,
     &                            NXY,WXY,CXY,SXY)
          ALLOCATE(RLATX(NO),RLONX(NO),CROTX(NO),SROTX(NO),
     &             NXY(2,2,NO),WXY(2,2,NO),CXY(2,2,NO),SXY(2,2,NO))
          NOX=NO
        ENDIF
        IRETX=IRET
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  COMPUTE WEIGHTS
        IF(IRET.EQ.0) THEN
          CALL IJKGDS0(KGDSI,IJKGDSA)
C$OMP PARALLEL DO
C$OMP&PRIVATE(N,XIJ,YIJ,IJX,IJY,XF,YF,J,I,WX,WY,CM,SM)
          DO N=1,NO
            RLONX(N)=RLON(N)
            RLATX(N)=RLAT(N)
            CROTX(N)=CROT(N)
            SROTX(N)=SROT(N)
            XIJ=XPTS(N)
            YIJ=YPTS(N)
            IF(XIJ.NE.FILL.AND.YIJ.NE.FILL) THEN
              IJX(1:2)=FLOOR(XIJ)+(/0,1/)
              IJY(1:2)=FLOOR(YIJ)+(/0,1/)
              XF=XIJ-IJX(1)
              YF=YIJ-IJY(1)
              WX(1)=(1-XF)
              WX(2)=XF
              WY(1)=(1-YF)
              WY(2)=YF
              DO J=1,2
                DO I=1,2
                  NXY(I,J,N)=IJKGDS1(IJX(I),IJY(J),IJKGDSA)
                  WXY(I,J,N)=WX(I)*WY(J)
                  IF(NXY(I,J,N).GT.0) THEN
                    CALL MOVECT(RLAI(NXY(I,J,N)),RLOI(NXY(I,J,N)),
     &                          RLAT(N),RLON(N),CM,SM)
                    CXY(I,J,N)=CM*CROI(NXY(I,J,N))+SM*SROI(NXY(I,J,N))
                    SXY(I,J,N)=SM*CROI(NXY(I,J,N))-CM*SROI(NXY(I,J,N))
                  ENDIF
                ENDDO
              ENDDO
            ELSE
              NXY(:,:,N)=0
            ENDIF
          ENDDO
        ENDIF
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  INTERPOLATE OVER ALL FIELDS
      IF(IRET.EQ.0.AND.IRETX.EQ.0) THEN
        IF(KGDSO(1).GE.0) THEN
          NO=NOX
          DO N=1,NO
            RLON(N)=RLONX(N)
            RLAT(N)=RLATX(N)
            CROT(N)=CROTX(N)
            SROT(N)=SROTX(N)
          ENDDO
        ENDIF
C$OMP PARALLEL DO
C$OMP&PRIVATE(NK,K,N,U,V,W,UROT,VROT,J,I)
        DO NK=1,NO*KM
          K=(NK-1)/NO+1
          N=NK-NO*(K-1)
          U=0
          V=0
          W=0
          DO J=1,2
            DO I=1,2
              IF(NXY(I,J,N).GT.0) THEN
                IF (IBI(K).EQ.0.OR.LI(NXY(I,J,N),K)) THEN
                  UROT=CXY(I,J,N)*UI(NXY(I,J,N),K)-
     &                 SXY(I,J,N)*VI(NXY(I,J,N),K)
                  VROT=SXY(I,J,N)*UI(NXY(I,J,N),K)+
     &                 CXY(I,J,N)*VI(NXY(I,J,N),K)
                  U=U+WXY(I,J,N)*UROT
                  V=V+WXY(I,J,N)*VROT
                  W=W+WXY(I,J,N)
                ENDIF
              ENDIF

            ENDDO
          ENDDO
          LO(N,K)=W.GE.PMP
          IF(LO(N,K)) THEN
            UROT=CROT(N)*U-SROT(N)*V
            VROT=SROT(N)*U+CROT(N)*V
            UO(N,K)=UROT/W
            VO(N,K)=VROT/W
          ELSE
            UO(N,K)=0.
            VO(N,K)=0.
          ENDIF
        ENDDO
        DO K=1,KM
          IBO(K)=IBI(K)
          IF(.NOT.ALL(LO(1:NO,K))) IBO(K)=1
        ENDDO
        IF(KGDSO(1).EQ.0) CALL POLFIXV(NO,MO,KM,RLAT,RLON,IBO,LO,UO,VO)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      ELSE
        IF(IRET.EQ.0) IRET=IRETX
        IF(KGDSO(1).GE.0) NO=0
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      END


subroutine SHReturnTapersM(theta0, lmax, m, tapers, eigenvalues, shannon)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This subroutine will return all the eigenvalues and
!	eigenfunctions for the space concentration problem of
!	a spherical cap of angular radius theta0. The returned
!	eigenfunctions correspond to "geodesy" normalized spherical
!	harmonic coefficients, and the eigenfunctions are further
!	normalized such that they have unit power (i.e., the integral
!	of the function squared over the sphere divided by 4 pi is 1, and the sum of
!	the squares of their coefficients is 1).
!
!	Note that the eigenfunctions are calculated using the
!	kernel of Grunbaum et al. 1982, and that the eigenvalues are
!	then calculated using the definition of the the space concentration
!	problem with its corresponding space concentration kerel. This
!	is done because the eigenfunctions of the former are unreliable
!	when the there are several eigenvalues
!	identical (to machine precision) to either 1 or zero.
!
!
!	Calling Parameters
!		IN
!			theta0		Angular radius of spherical cap
!					in RADIANS.
!			lmax		Maximum spherical harmonic degree
!					for the concentration problem.
!			m		Angular order of the concentration
!					problem (m=0 corresponds to isotropic
!					case).
!		OUT
!			tapers		An (lmax+1) by (lmax+1) array containing
!					all the eigenfunctions of the space-
!					concentration kernel. Eigenfunctions
!					are listed by columns in decreasing order
!					corresponding to value of their eigenvalue.
!			eigenvalues	A vector of length lmax+1 containing the
!					eigenvalued corresponding to the individual
!					eigenfunctions.
!		OPTIONAL
!			shannon		Shannon number as calculated from the trace of the
!					kernel.
!
!	Dependencies: LAPACK, BLAS, ComputeDG82, EigValVecSymTri, PreGLQ, PlmBar
!
!	Written by Mark Wieczorek 2003
!
!	Copyright (c) 2005, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use SHTOOLS, only: ComputeDG82, EigValVecSymTri, PreGLQ, PlmBar, PlmIndex

	implicit none

	real*8, intent(in) ::	theta0
	integer, intent(in) ::	lmax, m
	real*8, intent(out) ::	tapers(:,:), eigenvalues(:)
	real*8, intent(out), optional ::	shannon
	integer ::	l, n, n_int, j, i, astat(3)
	real*8 :: 	eval(lmax+1), pi, upper, lower, zero(lmax+1), w(lmax+1), h
	real*8, allocatable ::	evec(:,:), dllmtri(:,:), p(:)

	if (size(tapers(:,1)) < (lmax+1) .or. size(tapers(1,:)) < (lmax+1) ) then
		print*, "Error --- SHReturnTapersM"
		print*, "TAPERS must be dimensioned as ( LMAX+1, LMAX+1) where LMAX is ", lmax
		print*, "Input array is dimensioned as ", size(tapers(:,1)), size(tapers(1,:))
		stop
	elseif(size(eigenvalues) < (lmax+1) ) then
		print*, "Error --- SHReturnTapersM"
		print*, "EIGENVALUES must be dimensioned as (LMAX+1) where LMAX is ", lmax
		print*, "Input array is dimensioned as ", size(eigenvalues)
		stop
	elseif (m>lmax) then
		print*, "Error --- SHReturnTapersM"
		print*, "M must be less than or equal to LMAX."
		print*, "M = ", m
		print*, "LMAX = ", lmax
		stop
	endif

	allocate(evec(lmax+1, lmax+1), stat = astat(1))
	allocate(dllmtri(lmax+1, lmax+1), stat = astat(2))
	allocate(p((lmax+1)*(lmax+2)/2), stat = astat(3))
	if (astat(1) /= 0 .or. astat(2) /= 0 .or. astat(3) /= 0) then
		print*, "Error --- SHReturnTapersM"
		print*, "Problem allocating arrays EVEC, DLLMTRI, and P", &
			astat(1), astat(2), astat(3)
		stop
	endif

	pi = acos(-1.0d0)

	tapers = 0.0d0
	eigenvalues = 0.0d0
	eval = 0.0d0
	evec = 0.0d0

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Calculate space concentration Kernel, and the
	!	corresponding eigenfunctions of the Grunbaum et al. kernel.
	!	Calculate eigenvalues using concentration criter.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	n = lmax + 1 - abs(m)

	call ComputeDG82(dllmtri(1:n,1:n), lmax, m, theta0)

	call EigValVecSymTri(dllmtri(1:n,1:n), n, eval(1:n), evec(1+abs(m):lmax+1,1:n))

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Calculate true eigenvalues
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	upper = 1.0d0
	lower = cos(theta0)
	n_int = lmax+1

	call PreGLQ(lower, upper, n_int, zero, w)

	do i=1, n_int

		call PlmBar(p, lmax, zero(i))

		do j=1, lmax+1

			h = 0.0d0

			do l=abs(m), lmax
				h = h + p(PlmIndex(l, abs(m))) * evec(l+1, j)
			enddo

			eigenvalues(j) = eigenvalues(j) + w(i) * h**2
		enddo
	enddo

	if (m==0) then
		eigenvalues(1:lmax+1) = eigenvalues(1:lmax+1) / 2.0d0
	else
		eigenvalues(1:lmax+1) = eigenvalues(1:lmax+1) / 4.0d0
	endif

	if (present(shannon)) then
		shannon = sum(eigenvalues(1:lmax+1))
	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	! 	Normalize eigenvectors. By default, the eigenvectors have
	!	an L2 norm of 1, which corresponds to a total unit power
	!	(function^2 integreated over all space / 4pi = 1) when
	!	using the geodesy spherical harmonic normalization convenction.
	!	Modify sign convention of the eigenvectors such that the eigenfunction
	!	has a positive value at the north pole (form m=0 only).
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	if (m == 0) then

		do l=0, lmax
			p(l+1) = sqrt(dble(2*l+1))	! values of normalized Legendre Polynomials at north pole
		enddo

		do l=1, lmax+1
			!evec(:,l) =  evec(:,l) / sqrt(4.0d0*pi) 	! The integral of the taper squared is 1
			if (dot_product(evec(1:lmax+1,l), p(1:lmax+1)) < 0.0d0) evec(:,l) = -evec(:,l)
		enddo

	endif

	tapers(1:lmax+1,1:lmax+1) = evec(1:lmax+1,1:lmax+1)

	! deallocate memory
	call PlmBar(p, -1, zero(1))
	deallocate(evec)
	deallocate(dllmtri)
	deallocate(p)

end subroutine SHReturnTapersM


   !        Generated by TAPENADE     (INRIA, Tropics team)
   !  Tapenade 3.10 (r5363) -  9 Sep 2014 09:53
   !
   !  Differentiation of getrotationmatrix3d in reverse (adjoint) mode (with options noISIZE i4 dr8 r8):
   !   gradient     of useful results: v2 mi
   !   with respect to varying inputs: v2
   SUBROUTINE GETROTATIONMATRIX3D_B(v1, v2, v2b, mi, mib)
   USE PRECISION
   USE CONSTANTS
   IMPLICIT NONE
   ! Subroutine Variables
   REAL(kind=realtype), DIMENSION(3), INTENT(IN) :: v1, v2
   REAL(kind=realtype), DIMENSION(3) :: v1b, v2b
   REAL(kind=realtype), DIMENSION(3, 3) :: mi
   REAL(kind=realtype), DIMENSION(3, 3) :: mib
   ! Local Variables
   REAL(kind=realtype), DIMENSION(3) :: axis, vv1, vv2
   REAL(kind=realtype), DIMENSION(3) :: axisb, vv2b
   REAL(kind=realtype) :: magv1, magv2, axismag, angle, arg
   REAL(kind=realtype) :: magv2b, axismagb, angleb, argb
   REAL(kind=realtype), DIMENSION(3, 3) :: a, c
   REAL(kind=realtype), DIMENSION(3, 3) :: ab, cb
   REAL(kind=realtype), PARAMETER :: tol=1.4901161193847656e-08
   INTRINSIC MIN
   INTRINSIC ACOS
   INTRINSIC SIN
   INTRINSIC COS
   INTEGER :: branch
   CALL GETMAG(v1, magv1)
   CALL GETMAG(v2, magv2)
   ! Start by determining the rotation axis by getting the
   ! cross product between v1, v2
   CALL CROSS_PRODUCT_3D(v1, v2, axis)
   ! Now Normalize
   CALL GETMAG(axis, axismag)
   ! When axisMag is less that sqrt(eps), the acos 'arg' value will be
   ! exactly one which will give a nan in complex mode.
   IF (axismag .LT. tol) THEN
   ! no rotation at this point, angle is 0
   angle = zero
   ! the axis doesn't matter so set to x
   CALL PUSHREAL8ARRAY(axis, realtype*3/8)
   axis = zero
   axis(1) = one
   CALL PUSHCONTROL1B(0)
   ELSE
   CALL PUSHREAL8ARRAY(axis, realtype*3/8)
   axis = axis/axismag
   ! Now compute the rotation angle about that axis
   vv1 = v1/magv1
   vv2 = v2/magv2
   IF (one .GT. vv1(1)*vv2(1) + vv1(2)*vv2(2) + vv1(3)*vv2(3)) THEN
   arg = vv1(1)*vv2(1) + vv1(2)*vv2(2) + vv1(3)*vv2(3)
   CALL PUSHCONTROL1B(0)
   ELSE
   arg = one
   CALL PUSHCONTROL1B(1)
   END IF
   angle = ACOS(arg)
   CALL PUSHCONTROL1B(1)
   END IF
   ! Now that we have an axis and an angle,build the rotation Matrix
   ! A skew symmetric representation of the normalized axis
   a(1, 1) = zero
   a(1, 2) = -axis(3)
   a(1, 3) = axis(2)
   a(2, 1) = axis(3)
   a(2, 2) = zero
   a(2, 3) = -axis(1)
   a(3, 1) = -axis(2)
   a(3, 2) = axis(1)
   a(3, 3) = zero
   !C = A*A
   c(1, 1) = a(1, 1)*a(1, 1) + a(1, 2)*a(2, 1) + a(1, 3)*a(3, 1)
   c(1, 2) = a(1, 1)*a(1, 2) + a(1, 2)*a(2, 2) + a(1, 3)*a(3, 2)
   c(1, 3) = a(1, 1)*a(1, 3) + a(1, 2)*a(2, 3) + a(1, 3)*a(3, 3)
   c(2, 1) = a(2, 1)*a(1, 1) + a(2, 2)*a(2, 1) + a(2, 3)*a(3, 1)
   c(2, 2) = a(2, 1)*a(1, 2) + a(2, 2)*a(2, 2) + a(2, 3)*a(3, 2)
   c(2, 3) = a(2, 1)*a(1, 3) + a(2, 2)*a(2, 3) + a(2, 3)*a(3, 3)
   c(3, 1) = a(3, 1)*a(1, 1) + a(3, 2)*a(2, 1) + a(3, 3)*a(3, 1)
   c(3, 2) = a(3, 1)*a(1, 2) + a(3, 2)*a(2, 2) + a(3, 3)*a(3, 2)
   c(3, 3) = a(3, 1)*a(1, 3) + a(3, 2)*a(2, 3) + a(3, 3)*a(3, 3)
   ! Rodrigues formula for the rotation matrix
   ab = 0.0_8
   cb = 0.0_8
   angleb = SIN(angle)*SUM(c*mib) + COS(angle)*SUM(a*mib)
   ab = SIN(angle)*mib
   cb = (one-COS(angle))*mib
   ab(3, 1) = ab(3, 1) + a(1, 3)*cb(3, 3)
   ab(1, 3) = ab(1, 3) + a(3, 1)*cb(3, 3)
   ab(3, 2) = ab(3, 2) + a(2, 3)*cb(3, 3)
   ab(2, 3) = ab(2, 3) + a(3, 2)*cb(3, 3)
   ab(3, 3) = ab(3, 3) + 2*a(3, 3)*cb(3, 3)
   cb(3, 3) = 0.0_8
   ab(3, 1) = ab(3, 1) + a(1, 2)*cb(3, 2)
   ab(1, 2) = ab(1, 2) + a(3, 1)*cb(3, 2)
   ab(3, 2) = ab(3, 2) + (a(3, 3)+a(2, 2))*cb(3, 2)
   ab(2, 2) = ab(2, 2) + a(3, 2)*cb(3, 2)
   ab(3, 3) = ab(3, 3) + a(3, 2)*cb(3, 2)
   cb(3, 2) = 0.0_8
   ab(3, 1) = ab(3, 1) + (a(3, 3)+a(1, 1))*cb(3, 1)
   ab(1, 1) = ab(1, 1) + a(3, 1)*cb(3, 1)
   ab(3, 2) = ab(3, 2) + a(2, 1)*cb(3, 1)
   ab(2, 1) = ab(2, 1) + a(3, 2)*cb(3, 1)
   ab(3, 3) = ab(3, 3) + a(3, 1)*cb(3, 1)
   cb(3, 1) = 0.0_8
   ab(2, 1) = ab(2, 1) + a(1, 3)*cb(2, 3)
   ab(1, 3) = ab(1, 3) + a(2, 1)*cb(2, 3)
   ab(2, 2) = ab(2, 2) + a(2, 3)*cb(2, 3)
   ab(2, 3) = ab(2, 3) + (a(3, 3)+a(2, 2))*cb(2, 3)
   ab(3, 3) = ab(3, 3) + a(2, 3)*cb(2, 3)
   cb(2, 3) = 0.0_8
   ab(2, 1) = ab(2, 1) + a(1, 2)*cb(2, 2)
   ab(1, 2) = ab(1, 2) + a(2, 1)*cb(2, 2)
   ab(2, 2) = ab(2, 2) + 2*a(2, 2)*cb(2, 2)
   ab(2, 3) = ab(2, 3) + a(3, 2)*cb(2, 2)
   ab(3, 2) = ab(3, 2) + a(2, 3)*cb(2, 2)
   cb(2, 2) = 0.0_8
   ab(2, 1) = ab(2, 1) + (a(2, 2)+a(1, 1))*cb(2, 1)
   ab(1, 1) = ab(1, 1) + a(2, 1)*cb(2, 1)
   ab(2, 2) = ab(2, 2) + a(2, 1)*cb(2, 1)
   ab(2, 3) = ab(2, 3) + a(3, 1)*cb(2, 1)
   ab(3, 1) = ab(3, 1) + a(2, 3)*cb(2, 1)
   cb(2, 1) = 0.0_8
   ab(1, 1) = ab(1, 1) + a(1, 3)*cb(1, 3)
   ab(1, 3) = ab(1, 3) + (a(3, 3)+a(1, 1))*cb(1, 3)
   ab(1, 2) = ab(1, 2) + a(2, 3)*cb(1, 3)
   ab(2, 3) = ab(2, 3) + a(1, 2)*cb(1, 3)
   ab(3, 3) = ab(3, 3) + a(1, 3)*cb(1, 3)
   cb(1, 3) = 0.0_8
   ab(1, 1) = ab(1, 1) + a(1, 2)*cb(1, 2)
   ab(1, 2) = ab(1, 2) + (a(2, 2)+a(1, 1))*cb(1, 2)
   ab(2, 2) = ab(2, 2) + a(1, 2)*cb(1, 2)
   ab(1, 3) = ab(1, 3) + a(3, 2)*cb(1, 2)
   ab(3, 2) = ab(3, 2) + a(1, 3)*cb(1, 2)
   cb(1, 2) = 0.0_8
   ab(1, 1) = ab(1, 1) + 2*a(1, 1)*cb(1, 1)
   ab(1, 2) = ab(1, 2) + a(2, 1)*cb(1, 1)
   ab(2, 1) = ab(2, 1) + a(1, 2)*cb(1, 1)
   ab(1, 3) = ab(1, 3) + a(3, 1)*cb(1, 1)
   ab(3, 1) = ab(3, 1) + a(1, 3)*cb(1, 1)
   ab(3, 3) = 0.0_8
   axisb = 0.0_8
   axisb(1) = axisb(1) + ab(3, 2)
   ab(3, 2) = 0.0_8
   axisb(2) = axisb(2) - ab(3, 1)
   ab(3, 1) = 0.0_8
   axisb(1) = axisb(1) - ab(2, 3)
   ab(2, 3) = 0.0_8
   ab(2, 2) = 0.0_8
   axisb(3) = axisb(3) + ab(2, 1)
   ab(2, 1) = 0.0_8
   axisb(2) = axisb(2) + ab(1, 3)
   ab(1, 3) = 0.0_8
   axisb(3) = axisb(3) - ab(1, 2)
   CALL POPCONTROL1B(branch)
   IF (branch .EQ. 0) THEN
   CALL POPREAL8ARRAY(axis, realtype*3/8)
   magv2b = 0.0_8
   axisb = 0.0_8
   axismagb = 0.0_8
   ELSE
   IF (arg .EQ. 1.0 .OR. arg .EQ. (-1.0)) THEN
   argb = 0.0
   ELSE
   argb = -(angleb/SQRT(1.0-arg**2))
   END IF
   CALL POPCONTROL1B(branch)
   IF (branch .EQ. 0) THEN
   vv2b = 0.0_8
   vv2b(1) = vv2b(1) + vv1(1)*argb
   vv2b(2) = vv2b(2) + vv1(2)*argb
   vv2b(3) = vv2b(3) + vv1(3)*argb
   ELSE
   vv2b = 0.0_8
   END IF
   v2b = v2b + vv2b/magv2
   magv2b = SUM(-(v2*vv2b/magv2))/magv2
   CALL POPREAL8ARRAY(axis, realtype*3/8)
   axismagb = SUM(-(axis*axisb/axismag))/axismag
   axisb = axisb/axismag
   END IF
   CALL GETMAG_B(axis, axisb, axismag, axismagb)
   v1b = 0.0_8
   CALL CROSS_PRODUCT_3D_B(v1, v1b, v2, v2b, axis, axisb)
   CALL GETMAG_B(v2, v2b, magv2, magv2b)
   END SUBROUTINE GETROTATIONMATRIX3D_B


!----------------------------------------------------------------------
      subroutine bn_precal
! ----------------------------------------------------------------------
c                                                          11.09.99
c     purpose:
c
c
c ----------------------------------------------------------------------
      use meshes
      use bnvariables
      implicit none
      integer :: i, m, n, ku, kv
c ----------------------------------------------------------------------
         pi     = 2*asin(1._dp)
         pi2    = 2 * pi
         alp    = pi2 / (np)
         alu    = pi2 / (nu)
         alv    = pi2 / (nv)
         alvp   = pi2 / (nvp)
         fnuv   = 1._dp/(nuv)
c
      do  m=0,md
         i      = 0
       do  kv = 1,nv
        do  ku = 1,nu
         i      = i + 1
         conu(i,m) = cos(alu*m*(ku-1))
         sinu(i,m) = sin(alu*m*(ku-1))
        enddo
       enddo
      enddo
      do  n=-nd,nd
         i      = 0
       do  kv = 1,nv
        do  ku = 1,nu
         i      = i + 1
         sinv(i,n) = sin(alv*n*(kv-1))
         conv(i,n) = cos(alv*n*(kv-1))
        enddo

       enddo
       do  i=1,nuv
         sinv(i,-n) = -sinv(i,n)
         conv(i,-n) =  conv(i,n)
       enddo
      enddo
      do kv=1,nvp
       do ku=1,nu
         i    = ku + nu*(kv-1)
         indv(i)  = kv
         indu(i)  = ku
       enddo
      enddo
      do  ku = -nu+1,nu-1
       if(iabs(ku).ne.nu/2) then
         tanu(ku) = tan(.5_dp*alu*ku)/pi
       else
         tanu(ku)=1.e+20_dp
       endif
      enddo
      do  kv = -nvp+1,nvp-1
       if(iabs(kv).ne.nvp/2) then
         tanv(kv) = tan(.5_dp*alvp*kv)/pi
        else
         tanv(kv) = 1.e+20_dp
        endif
      enddo

      end subroutine bn_precal


      subroutine eigen(N,A)
      implicit real*8(a-h,o-z)
      INTEGER,intent(in) :: N
      complex*16,intent(in) :: A(n,n)
      INTEGER          LWMAX
      PARAMETER        ( LWMAX = 1000 )
      INTEGER          INFO, LWORK
*     .. Local Arrays ..
*     RWORK dimension should be at least MAX(1,3*N-2)
      DOUBLE PRECISION W( N ), RWORK( 3*N-2 )
      COMPLEX*16       WORK( LWMAX )
      LDA = N
*     .. External Subroutines ..
!      EXTERNAL         ZHEEV
!      EXTERNAL         PRINT_MATRIX, PRINT_RMATRIX
*
*     .. Intrinsic Functions ..
!      INTRINSIC        INT, MIN
*
*     .. Executable Statements ..
!      WRITE(*,*)'ZHEEV Example Program Results'
*
*     Query the optimal workspace.
*
      LWORK = -1
      CALL ZHEEV( 'Vectors', 'Lower', N, A, LDA, W, WORK, LWORK, RWORK,
     $            INFO )
      LWORK = MIN( LWMAX, INT( WORK( 1 ) ) )
*
*     Solve eigenproblem.
*
      CALL ZHEEV( 'Vectors', 'Lower', N, A, LDA, W, WORK, LWORK, RWORK,
     $            INFO )
*
*     Check for convergence.
*
      IF( INFO.GT.0 ) THEN
         WRITE(*,*)'The algorithm failed to compute eigenvalues.'
         STOP
      END IF
*
*     Print eigenvalues.
*
      CALL PRINT_RMATRIX( 'Eigenvalues', 1, N, W, 1 )
*
*     Print eigenvectors.
*
      CALL PRINT_MATRIX( 'Eigenvectors (stored columnwise)', N, N, A,
     $                   LDA )

      END subroutine
*
*     End of ZHEEV Example.
*
*  =============================================================================
*
*     Auxiliary routine: printing a matrix.
*
      SUBROUTINE PRINT_MATRIX( DESC, M, N, A, LDA )
      CHARACTER*(*)    DESC
      INTEGER          M, N, LDA
      COMPLEX*16       A( LDA, * )
*
      INTEGER          I, J
*
      WRITE(*,*)
      WRITE(*,*) DESC
      DO I = 1, M
         WRITE(*,9998) ( A( I, J ), J = 1, N )
      END DO
*
 9998 FORMAT( 11(:,1X,'(',F6.2,',',F6.2,')') )
      RETURN
      END
*
*     Auxiliary routine: printing a real matrix.
*
      SUBROUTINE PRINT_RMATRIX( DESC, M, N, A, LDA )
      CHARACTER*(*)    DESC
      INTEGER          M, N, LDA
      DOUBLE PRECISION A( LDA, * )
*
      INTEGER          I, J
*
      WRITE(*,*)
      WRITE(*,*) DESC
      DO I = 1, M
         WRITE(*,9998) ( A( I, J ), J = 1, N )
      END DO
*
 9998 FORMAT( 11(:,1X,F6.4) )
      RETURN
      END
!--------read matrix from external file--------------
      subroutine read_matrix(nd,A)
      implicit real*8(a-h,o-z)
      integer nd
      complex*16 A(nd,nd)
      open(10,file='matrix')
      do i=1,nd
        read(10,*) (A(i,j),j=1,nd)
      enddo
      close(10)

      return
      end subroutine


Module mod_optimization
!$$$  program documentation block
!         .           .            .
!  program name: mod_optimization
!    programmer: da,cheng        org: umd      date: 2015-Dec-07
!
!  purpose:
!    minimization module
!
!  revision history:
!    2015-Dec-07     da    - creator
!
!  file dependencies:
!
!  attributes:
!    language: fortran 90
!    machine :
!
!
!$$$ end documentation block
  Implicit none

  Private
  Public :: run_lbfgs
  Public :: destroy_lbfgs

  integer,parameter :: r8 = 8

  Type :: tLBGFS
    logical :: linit   = .false.
    logical :: ldiagco = .false.
    integer :: ndim    = 0      ! dimensions of the control variables (n)
    integer :: ncorr   = 0      ! number of correction used in the bgfs update (m)
    integer :: iprint(2)    = 0
    integer :: iflag        = 0
    real(r8) :: eps_machine = 0.d0 ! (xtol)
    real(r8),allocatable :: wk(:) ! workspace (w)
    real(r8),allocatable :: rdiag(:)  ! (diag)
  Endtype

  Type(tLBGFS), save :: config_lbfgs

Contains

Subroutine initialize_lbfgs( ndim )
!$$$ subprogram documentation block
!             .                   .                    .
!  Program name:
!    programmer: Da,Cheng       org: umd            date: 2015-MON-DD
!
!  Purpose:
!
!
!  Revision history:
!    2015-MON-DD     Da,Cheng     -Creator
!
!  Input args:
!
!  Output args:
!
!
!
!$$$
  Implicit None
! Passed args
  Integer,intent(in) :: ndim
! Local vars
  Integer :: nwk

! default settings
  config_lbfgs%ncorr     = 7  ! should be >0. 3~7 recommended
  config_lbfgs%ldiagco   = .FALSE.
  config_lbfgs%iprint(1) = 1
  config_lbfgs%iprint(2) = 0
  config_lbfgs%iflag     = 0

! set dims of control vars
  config_lbfgs%ndim      = ndim
! get machine precision
  config_lbfgs%eps_machine = EPSILON(0.0d0)
  !config_lbfgs%eps_machine = 1.d-13
! allocate arrays
  allocate( config_lbfgs%rdiag(config_lbfgs%ndim) )
  config_lbfgs%rdiag = 0.0d0
  nwk = config_lbfgs%ndim*(2*config_lbfgs%ncorr+1) + &
        2*config_lbfgs%ncorr
  allocate( config_lbfgs%wk(nwk) )

  config_lbfgs%linit = .TRUE.

Endsubroutine

Subroutine run_lbfgs( ndim, x, func, grad, eps_opt, istatus )
!$$$ subprogram documentation block
!             .                   .                    .
!  Program name:
!    programmer: Da,Cheng       org: umd            date: 2015-MON-DD
!
!  Purpose:
!
!
!  Revision history:
!    2015-MON-DD     Da,Cheng     -Creator
!
!  Input args:
!
!  Output args:
!
!
!
!$$$
  Implicit None
! Passed args
  Integer,intent(in) :: ndim
  Real(r8),intent(inout) :: x(ndim)
  Real(r8),intent(inout) :: func
  Real(r8),intent(inout) :: grad(ndim)
  Real(r8),intent(in) :: eps_opt
  Integer,intent(out) :: istatus

! vars required by subroutine LBFGS
  external LB2
  integer :: MP, LP
  real(r8) :: GTOL, STPMIN, STPMAX
  COMMON /LB3/MP,LP,GTOL,STPMIN,STPMAX

! peform some check
  If ( .not.(config_lbfgs%linit) ) Then
     Write(6,*), "1st run of LBFGS algorithm: initialize vars"
     Call initialize_lbfgs( ndim )
  Endif

  Call LBFGS( config_lbfgs%ndim, config_lbfgs%ncorr, x, func, grad, &
              config_lbfgs%ldiagco, config_lbfgs%rdiag, &
              config_lbfgs%iprint, eps_opt, config_lbfgs%eps_machine, &
              config_lbfgs%wk, config_lbfgs%iflag )
  istatus = config_lbfgs%iflag
  If ( config_lbfgs%iflag == 0 ) Then
     Write(6,*) "finish minimization procedure"
     Call Destroy_lbfgs()
  Endif

Endsubroutine

Subroutine destroy_lbfgs()
!$$$ subprogram documentation block
!             .                   .                    .
!  Program name:
!    programmer: Da,Cheng       org: umd            date: 2015-MON-DD
!
!  Purpose:
!
!
!  Revision history:
!    2015-MON-DD     Da,Cheng     -Creator
!
!  Input args:
!
!  Output args:
!
!
!
!$$$
  Implicit None

  If ( .not.( config_lbfgs%linit ) ) Return
  config_lbfgs%ndim  = 0
  config_lbfgs%ncorr = 0
  config_lbfgs%eps_machine = 0.d0
  If ( Allocated( config_lbfgs%wk ) ) Deallocate( config_lbfgs%wk )
  If ( Allocated( config_lbfgs%rdiag ) ) Deallocate( config_lbfgs%rdiag )

  config_lbfgs%linit = .FALSE.

Endsubroutine

Endmodule


!-----------------------------------------------------------------------
      program test

      include 'ceedf.h'

      integer ceed,err
      integer u,v
      integer qf
      integer q,s,i
      parameter(q=8)
      parameter(s=3)
      real*8 uu(q*s)
      real*8 vv(q*s)
      character arg*32
      integer*8 uoffset,voffset

      call getarg(1,arg)
      call ceedinit(trim(arg)//char(0),ceed,err)

      call ceedqfunctioncreateidentity(ceed,s,ceed_eval_interp,&
     & ceed_eval_interp,qf,err)

      do i=0,q*s-1
        uu(i+1)=i*i
      enddo

      call ceedvectorcreate(ceed,q*s,u,err)
      uoffset=0
      call ceedvectorsetarray(u,ceed_mem_host,ceed_use_pointer,uu,uoffset,err)
      call ceedvectorcreate(ceed,q*s,v,err)
      call ceedvectorsetvalue(v,0.d0,err)

      call ceedqfunctionapply(qf,q,u,ceed_null,ceed_null,ceed_null,&
             &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,&
             &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,&
             &v,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,&
             &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,&
             &ceed_null,ceed_null,ceed_null,ceed_null,err)

      call ceedvectorgetarrayread(v,ceed_mem_host,vv,voffset,err)
      do i=1,q*s
        if (abs(vv(i+voffset)-(i-1)*(i-1)) > 1.0D-12) then
! LCOV_EXCL_START
          write(*,*) 'v(i)=',vv(i+voffset),', u(i)=',(i-1)*(i-1)
! LCOV_EXCL_STOP
        endif
      enddo
      call ceedvectorrestorearrayread(v,vv,voffset,err)

      call ceedvectordestroy(u,err)
      call ceedvectordestroy(v,err)
      call ceedqfunctiondestroy(qf,err)
      call ceeddestroy(ceed,err)
      end
!-----------------------------------------------------------------------


c
c************************************
c
        subroutine demean(x,m,n)
        real x(m,n),xbar(25)

        do 5 j=1,m
        xbar(j)=0.0
        do 2 i=1,n
        xbar(j)=xbar(j)+x(j,i)
2       continue
        xbar(j)=xbar(j)/n
5       continue

        do 10 j=1,m
        do 10 i=1,n
        x(j,i)=x(j,i)-xbar(j)
10      continue

        return
        end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C----M  A  T  R  I  X   U  T  I  L  I  T  I  E  S   B  L  O  C  K------C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE CLEAR                                                   C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE CLEAR(A,IN,IM)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER (ZERO=0.D0)
C
      DIMENSION A(IN,IM)
C
      DO I=1,IN
        DO J=1,IM
          A(I,J)=ZERO
        END DO
      END DO
C
      RETURN
C
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE CLEARV                                                  C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE CLEARV (A,N)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER (ZERO=0.D0)
C
      DIMENSION A(N)
C
      DO I=1,N
        A(I)=ZERO
      END DO
C
      RETURN
C
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE MMULT                                                   C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE MMULT(A,NRA,NCA,B,NRB,NCB,C)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION A(NRA,NCA),B(NRB,NCB),C(NRA,NCB)
C
      CALL CLEAR(C,NRA,NCB)
      DUM=0.0D0
      DO I=1,NRA
        DO J=1,NCB
          DO K=1,NCA
            DUM=DUM+A(I,K)*B(K,J)
          END DO
          C(I,J)=DUM
          DUM=0.0D0
        END DO
      END DO
C
      RETURN
C
      END
C
C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE DOTPRO                                                  C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE DOTPRO(A,B,C,NR)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION A(NR),B(NR)
C
      C=0.0D0
      DO I=1,NR
        C=C+A(I)*B(I)
      END DO
C
      RETURN
C
      END
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE MTRAN                                                   C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE MTRAN(A,NRA,NCA,B)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION A(NRA,NCA),B(NCA,NRA)
C
      DO I=1,NRA
        DO J=1,NCA
          B(J,I)=A(I,J)
        END DO
      END DO
C
      RETURN
C
      END

C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE NORMVCT                                                 C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE NORMVCT(X1,X2,Y1,Y2,CT,ST)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DX=X2-X1
      DY=Y2-Y1
      VMAG=DSQRT(DX*DX+DY*DY)
      CT=-DY/VMAG
      ST=DX/VMAG
C
      RETURN
C
      END

C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE TRANSFORMA                                              C
C   ESTA RUTINA ENCUENTRA LA MATRIZ DE TRANSFORMACIÓN DE UN SISTEMA 3D C
C   A UN SISTEMA LOCAL DEFINIDO POR UNA SUPERFICIE PLANA EN 3D.        C
C   ADICIONALMENTE ENTREGA LAS COORDENADAS LOCALES DE LOS CUATRO       C
C   PUNTOS QUE DEFINEN EL ELEMENTO EN 3D.                              C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE TRANSFORMA(COORDS, T, XY)
C
      IMPLICIT REAL*8 (A-H,O-Z)

	  DIMENSION COORDS(3,4), T(3,3), P1(3), P2(3), P3(3), P4(3),V1(3),
     1			V2(3), V3(3), V4(3), P1T(3), P2T(3), P3T(3), P4T(3),
     2			XY(2, 4)
C

C	  COORDENADAS DE LOS PUNTOS DEL ELEMENTO DE SUPERFICIE.
C	  MUEVO LAS COORDENADAS DE FORMA TAL QUE LA COORDENADA EN Z DEL
C	  PUNTO 2 QUEDE CON LA COORDENADA Z EN CERO.

      P1(1)=COORDS(1,1)
      P1(2)=COORDS(2,1)
      P1(3)=COORDS(3,1)-COORDS(3,2)

      P2(1)=COORDS(1,2)
      P2(2)=COORDS(2,2)
      P2(3)=COORDS(3,2)-COORDS(3,2)

      P3(1)=COORDS(1,3)
      P3(2)=COORDS(2,3)
      P3(3)=COORDS(3,3)-COORDS(3,2)

      P4(1)=COORDS(1,4)
      P4(2)=COORDS(2,4)
      P4(3)=COORDS(3,4)-COORDS(3,2)

C	  EL VECTOR V1 CORRESPONDE A UN LADO DEL ELEMENTO DE SUPERFICIE
C	  Y SERÁ PARALELO AL EJE Y'

	  V1(1)= P1(1)-P2(1)
	  V1(2)= P1(2)-P2(2)
	  V1(3)= P1(3)-P2(3)

C	  EL VECTOR V2 CORRESPONDE A UN LADO DEL ELEMENTO DE SUPERFICIE
C	  Y SE EMPLEA PARA ENCONTRAR EL VECTOR V3, EL CUAL ES PARALELO AL
C	  EJE Z'

	  V2(1)= P3(1)-P2(1)
	  V2(2)= P3(2)-P2(2)
	  V2(3)= P3(3)-P2(3)

C	  VECTOR V3, PARALELO AL EJE Z' Y NORMAL AL ELEMENTO. SE CALCULA
C	  CON EL PRODUCTO CRUZ ENTRE EL VECTOR V2 Y V1.

	  V3(1)= V1(2)*V2(3)-V1(3)*V2(2)
	  V3(2)= V1(3)*V2(1)-V1(1)*V2(3)
	  V3(3)= V1(1)*V2(2)-V1(2)*V2(1)

	  V1M=DSQRT(V1(1)**2+V1(2)**2+V1(3)**2)
	  V3M=DSQRT(V3(1)**2+V3(2)**2+V3(3)**2)

C	  ACÁ VUELVO UNITARIO LOS VECTORES V1 Y V3

	  V1=V1/V1M
	  V3=V3/V3M

C	  VECTOR V4, EL CUAL ES PARALELO AL EJE X'.

	  V4(1)= V3(2)*V1(3)-V3(3)*V1(2)
	  V4(2)= V3(3)*V1(1)-V3(1)*V1(3)
	  V4(3)= V3(1)*V1(2)-V3(2)*V1(1)

C	  MATRIZ DE TRANSFORMACIÓN

C  T(1,:)= V4
C  T(2,:)= V1
C  T(3,:)= V3

	  T(:,1)= V3
	  T(:,2)= V4
	  T(:,3)= V1
C
	  P1T=MATMUL(T, P1)
	  P2T=MATMUL(T, P2)
	  P3T=MATMUL(T, P3)
	  P4T=MATMUL(T, P4)

	  XY(:,1)= P1T(1:2)
	  XY(:,2)= P2T(1:2)
	  XY(:,3)= P3T(1:2)
	  XY(:,4)= P4T(1:2)

      RETURN
C
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE NORMVCTINT                                              C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE NORMVCTINT(X1,X2,Y1,Y2,CT,ST)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DX=X2-X1
      DY=Y1-Y2
      VMAG=DSQRT(DX*DX+DY*DY)
      CT= DY/VMAG
      ST= DX/VMAG
C
      RETURN
C
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE CLEARIV                                                 C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE CLEARIV(IA,N)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION IA(N)
C
      DO I=1,N
        IA(I)=0
      END DO
C
      RETURN
C
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE CLEARIM                                                 C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE CLEARIM(IA,N,M)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      DIMENSION IA(N,M)
C
      DO I=1,N
        DO J=1,M
          IA(I,J)=0
        END DO
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE MAVEC(A,NRA,NCA,B,C)                                C
C      Real matrix times vector                                        C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE MAVEC(A,NRA,NCA,B,C)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER(ZERO=0.D0)
      DIMENSION A(NRA,NCA),B(NCA),C(NRA)
C
      CALL CLEARV(C,NRA)
C
      DO K1=1,NRA
        DO K2=1,NCA
          C(K1)=C(K1)+A(K1,K2)*B(K2)
        END DO
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE SMULT(A,NR,NC,S)                                     C
C      Matrix times a real scalar                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE SMULT(A,NR,NC,S)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION A(NR,NC)
C
      DO I=1,NR
        DO J=1,NC
          DUM=A(I,J)
          A(I,J)=S*DUM
          DUM=0.D0
        END DO
      END DO
C
      RETURN
C
      END
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE SMULTV(A,NC,S)                                       C
C      Vector times a real scalar                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE SMULTV(A,NC,S)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION A(NC)
C
      DO I=1,NC
        DUM=A(I)
        A(I)=S*DUM
        DUM=0.D0
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE SMULTI(A,NR,NC,S)                                    C
C      Matrix times an integer                                         C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE SMULTI(A,NR,NC,JJ)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION A(NR,NC)
C
      DO I=1,NR
        DO J=1,NC
          DUM=A(I,J)
          A(I,J)=JJ*DUM
          DUM=0.D0
        END DO
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE UPDMAT(A,NR,NC,B)                                    C
C      Updates an existing matrix with an incremental matrix.          C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE UPDMAT(A,NR,NC,B)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER(ZERO=0.D0)
C
      DIMENSION A(NR,NC),B(NR,NC)
C
      DO I=1,NR
        DO J=1,NC
          DUM=A(I,J)
          A(I,J)=ZERO
          A(I,J)=DUM+B(I,J)
          DUM=ZERO
        END DO
      END DO
C
      RETURN
C
      END
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE UPDVEC(A,NC,B)                                       C
C      Updates an existing vector with an incremental vector.          C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE UPDVEC(A,NC,B)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER(ZERO=0.D0)
C
      DIMENSION A(NC),B(NC)
C
      DO I=1,NC
        DUM=A(I)
        A(I)=ZERO
        A(I)=DUM+B(I)
        DUM=ZERO
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE CLEAR3D                                                 C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE CLEAR3D(A,IN,IM,IL)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER (ZERO=0.D0)
C
      DIMENSION A(IN,IM,IL)
C
      DO I=1,IN
        DO J=1,IM
          DO K=1,IL
            A(I,J,K)=ZERO
          END DO
        END DO
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE CLEAR4D                                                 C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE CLEAR4D(A,IN,IM,IL,IK)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER (ZERO=0.D0)
C
      DIMENSION A(IN,IM,IL,IK)
C
      DO N=1,IN
        DO M=1,IM
          DO L=1,IL
            DO K=1,IK
              A(N,M,L,K)=ZERO
            END DO
          END DO
        END DO
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE KVECSUB(A,NRA,B,NRB,C)                               C
C      Substracts one column vector from another column vector         C
C      IFLAG=0 for substraction                                        C
C      IFLAG=1 for addition                                            C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE VECSUB(A,NRA,B,NRB,C,IFLAG)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER (ONE=1.0D0, ONENEG=-1.0D0)
C
      DIMENSION A(NRA,1),B(NRB,1),C(NRB,1)
C
      CALL CLEAR(C,NRB,1)
C
      SCALAR=ONENEG
C
      IF (IFLAG.EQ.1) SCALAR=ONE
C
      DO I=1,NRA
        C(I,1)=A(I,1)+B(I,1)*SCALAR
      END DO
C
      RETURN
C
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE SQRNORM(A,NRA,E)                                     C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE SQRNORM(A,NRA,E)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER(ZERO=0.D0)
C
      DIMENSION A(NRA)
C
      SQS=ZERO
      DO K1=1,NRA
        SQS=SQS+A(K1)**2
      END DO
C
      E=DSQRT(SQS)
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C     SUBROUTINE VECHAN3D4D                                            C
C     IFLAG=0 =  3D-->4D                                               C
C     IFLAG=1 =  4D-->3D                                               C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      SUBROUTINE VECHAN3D4D(RV4D,ID1,ID2,ID3,ID4,ICOL,RV3D,JD1,JD2,JD3,
     1IFLAG)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      DIMENSION RV4D(ID1,ID2,ID3,ID4),RV3D(JD1,JD2,JD3)
C
      IF(IFLAG.EQ.0) THEN
         DO K1=1,ID1
           DO K2=1,ID2
             DO K3=1,ID3
               RV4D(K1,K2,K3,ICOL)=RV3D(K1,K2,K3)
             END DO
           END DO
         END DO
      ELSE
         DO K1=1,ID1
           DO K2=1,ID2
             DO K3=1,ID3
               RV3D(K1,K2,K3)=RV4D(K1,K2,K3,ICOL)
             END DO
           END DO
         END DO
      END IF
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C     SUBROUTINE VECHAN2D3D                                            C
C     IFLAG=0 =  2D-->3D                                               C
C     IFLAG=1 =  3D-->2D                                               C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      SUBROUTINE VECHAN2D3D(RV3D,ID1,ID2,ID3,ICOL,RV2D,JD1,JD2,IFLAG)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      DIMENSION RV3D(ID1,ID2,ID3),RV2D(JD1,JD2)
C
      IF(IFLAG.EQ.0) THEN
         DO K1=1,ID1
           DO K2=1,ID2
             RV3D(K1,K2,ICOL)=RV2D(K1,K2)
           END DO
         END DO
      ELSE
         DO K1=1,ID1
           DO K2=1,ID2
             RV2D(K1,K2)=RV3D(K1,K2,ICOL)
           END DO
         END DO
      END IF
C
      RETURN
C
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C SUBROUTINE KPBLOCK                                                   C
C                                                                      C
C PASSES A BLOCK OF A SOURCE MATRIX (SMAT) INTO A TARGET MATRIX (TMAT) C
C STARTING AT ROW ISR AND COLUMN ISC AND ENDING AT ROW IFSR AND COLUMN C
C IFSC                                                                 C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE PBLOCK(TMAT,NRT,NCT,SMAT,NRS,NCS,ISR,ISC,IFSR,IFSC)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION TMAT(NRT,NCT),SMAT(NRS,NCS)
C
      CALL CLEAR(TMAT,NRT,NCT)
C
      IF((IFSR-ISR+1).NE.NRT.OR.(IFSC-ISC+1).NE.NCT) THEN
         WRITE (*,*) '****ERROR NO MATCHING PASING BLOCKS****'
         GOTO 10
      END IF
C
      II=ISR
      JJ=ISC
      DO K1=1,NRT
        DO K2=1,NCT
          TMAT(K1,K2)=SMAT(II,JJ)
          JJ=JJ+1
        END DO
        II=II+1
        JJ=ISC
      END DO
C
   10 CONTINUE
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE MATSUB(A,NRA,NCA,B,C,IFLAG)                          C
C      Substracts one rectangular matrix from another rectangular      C
C      matrix                                                          C
C      IFLAG=0 for substraction                                        C
C      IFLAG=1 for addition                                            C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE MATSUB(A,NRA,NCA,B,C,IFLAG)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER (ONE=1.0D0, ONENEG=-1.0D0)
C
      DIMENSION A(NRA,NCA),B(NRA,NCA),C(NRA,NCA)
C
      CALL CLEAR(C,NRA,NCA)
C
      IF (IFLAG.EQ.1) SCALAR=ONE
      IF (IFLAG.EQ.0) SCALAR=ONENEG
C
      DO I=1,NRA
        DO J=1,NCA
          C(I,J)=A(I,J)+B(I,J)*SCALAR
        END DO
      END DO
C
      RETURN
C
      END
C
C11111111122222222223333333333444444444455555555556666666666777777777777
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C     SUBROUTINE IDENTITY                                              C
C     CREATES AN IDENTITY MATRIX OF DIMENSIONS NDIM,NDIM               C
C                                                                      C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      SUBROUTINE IDENTITY(DEL,NDIM)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER(ONE=1.D0)
C
      DIMENSION DEL(NDIM,NDIM)
C
      CALL CLEAR(DEL,NDIM,NDIM)
C
      DO K1=1,NDIM
        DEL(K1,K1)=ONE
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE INVERSE                                                 C
C                                                                      C
C   IVEERSE OF A MATRIX USING LU DECOMPOSITION                         C
C   TAKEN FROM NUMERICAL RECIPES By Press et al                        C
C                                                                      C
C   A   Matrix to be inverted.                                         C
C   Y   Inverse of A                                                   C
C   N   Dimension                                                      C
C                                                                      C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE INVERSE(A,Y,NP,N)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER (ZERO=0.D0,ONE=1.D0)
C
      DIMENSION A(NP,NP),Y(NP,NP),INDX(NP),AUX(NP,NP)
C
      CALL CLEAR(AUX,NP,NP)
      CALL COPYMAT(A,AUX,N)
C
      DO I=1,N
        DO J=1,N
          Y(I,J)=ZERO
        END DO
        Y(I,I)=ONE
      END DO
      CALL LUDCMP(AUX,N,NP,INDX,D)
      DO J=1,N
        CALL LUBKSB(AUX,N,NP,INDX,Y(1,J))
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE LUDCMP                                                  C
C                                                                      C
C   LU MATRIX DECOMPOSITION                                            C
C   TAKEN FROM NUMERICAL RECIPES By Press et al                        C
C                                                                      C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE LUDCMP(A,N,NP,INDX,D)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER(NMAX=500,TINY=1.0E-20,ZERO=0.D0,ONE=1.D0)
C
      DIMENSION INDX(N),A(NP,NP),VV(NMAX)
C
      D=ONE
      DO I=1,N
        AAMAX=ZERO
        DO J=1,N
          IF(ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
        END DO
        IF(AAMAX.EQ.0.) WRITE (*,*) 'SINGULAR MATRIX IN LUDCMP'
        READ (*,*) FFF
        VV(I)=ONE/AAMAX
      END DO
C
      DO J=1,N
        DO I=1,J-1
          SUM=A(I,J)
          DO K=1,I-1
            SUM=SUM-A(I,K)*A(K,J)
          END DO
          A(I,J)=SUM
        END DO
        AAMAX=ZERO
        DO I=J,N
          SUM=A(I,J)
          DO K=1,J-1
            SUM=SUM-A(I,K)*A(K,J)
          END DO
          A(I,J)=SUM
          DUM=VV(I)*ABS(SUM)
          IF(DUM.GE.AAMAX) THEN
             IMAX=I
             AAMAX=DUM
          END IF
        END DO
        IF(J.NE.IMAX) THEN
           DO K=1,N
             DUM=A(IMAX,K)
             A(IMAX,K)=A(J,K)
             A(J,K)=DUM
           END DO
           D=-D
           VV(IMAX)=-VV(J)
        END IF
        INDX(J)=IMAX
        IF(A(J,J).EQ.0.) A(J,J)=TINY
        IF(J.NE.N) THEN
           DUM=ONE/A(J,J)
           DO I=J+1,N
             A(I,J)=A(I,J)*DUM
           END DO
        END IF
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE LUBKSB                                                  C
C                                                                      C
C   FORWARD SUBSTITUTION                                               C
C   TAKEN FROM NUMERICAL RECIPES By Press et al                        C
C                                                                      C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE LUBKSB(A,N,NP,INDX,B)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER (ZERO=0.D0)
C
      DIMENSION INDX(N),A(NP,NP),B(NP)
C
      II=0
      DO I=1,N
        LL=INDX(I)
        SUM=B(LL)
        B(LL)=B(I)
        IF(II.NE.0) THEN
           DO J=II,I-1
             SUM=SUM-A(I,J)*B(J)
           END DO
        ELSE IF(SUM.NE.ZERO) THEN
           II=I
        END IF
        B(I)=SUM
      END DO
C
      DO I=N,1,-1
        SUM=B(I)
        DO J=I+1,N
          SUM=SUM-A(I,J)*B(J)
        END DO
        B(I)=SUM/A(I,I)
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C     SUBROUTINE COPYMAT                                               C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      SUBROUTINE COPYMAT(A,B,N)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      DIMENSION A(N,N),B(N,N)
C
      CALL CLEAR(B,N,N)
C
      DO K1=1,N
        DO K2=1,N
          B(K1,K2)=A(K1,K2)
        END DO
      END DO
C
      RETURN
C
      END
C


module probdata_module

      use amrex_fort_module, only : rt => amrex_real
      real(rt)         Pi
      parameter (Pi=3.1415926535897932384e0_rt)

      real(rt)        , save :: rhocv, T0, Eexp, rexp

      real(rt)        , save :: xmin,xmax,ymin,ymax,zmin,zmax

end module probdata_module


      program kvsTest
      implicit none

      logical   	kvscheckown
C     cinfo is an opaque type holding KVS connection info.
      integer*4 	cinfo(3), rank, nclones, chunk /13/,
     $     limit /1234/, psum(3)
      integer   	i, sum /0/, work /0/
      integer		t0, time
      character*10	cchunk, climit

C     Disable kvs tracing.
      cinfo(3) = 0
C     Connect to the key/value service.
      call kvsconnect(cinfo)

C     Figure out our role in this run.
      call slurmme(rank, nclones)
      print '(A4,I4,A4,I6)',
     $     'Rank ', rank, ' of ', nclones

C     The work in this loop will be split among all participants into
C     blocks of size "chunk".
      t0 = time()
      do i = 0, limit-1
         if ( kvscheckown(cinfo, rank, nclones, chunk, 'ticket') ) then
            sum = sum + 2*i + 1
            work = work + 1
C     Arrange for some clones to be slower than others.
            call sleep(mod(rank,2)+1)
         endif
      enddo
      psum(1) = rank
      psum(2) = work
      psum(3) = sum

C     Merge partial results.
      call kvsput(cinfo, 'psum', psum, 4*3)

      if ( rank .eq. 0 ) then
         sum = 0
         do i = 1, nclones
            call kvsget(cinfo, 'psum', psum)
            print *, psum(1), ' ', psum(2), ' => ', psum(3)
            sum = sum + psum(3)
         enddo
         print *, 'Sum of the first ', limit, ' odd integers: ', sum
         print *, 'Elapsed: ', time() - t0
      endif
      stop
      end


subroutine makesym(matrix)
!	Symmetrize n by n matrix based on lower triangle.
implicit none
real(kind=8),intent(inout)::matrix(:,:)
!	col is column.
!	n is matrix size.
!	row is row.
integer::row,col,n
n=size(matrix,1)
if(n>1) then
	do row=2,n
		do col=1,row-1
			matrix(col,row)=matrix(row,col)
		end do
	end do
end if
return
end subroutine makesym


C++***************************************************************
C Program to test FFT and Fourier transforms
C
C JLP
C Version of 12-07-91
C--***************************************************************
	PROGRAM FFT1
	PARAMETER (IDIM=200)
	REAL IMAGR(IDIM,IDIM),IMAGI(IDIM,IDIM),IMAGE(IDIM,IDIM)
     	INTEGER KOD
	CHARACTER NAME*40,COMMENTS*80

        CALL JLP_BEGIN
C Inquire the format (input/output) :
	CALL JLP_INQUIFMT

C Test:
	NX=32
	NY=NX
	DO J=1,NY
	  DO I=1,NX
	    IMAGR(I,J)=0.
          END DO
        END DO

	IMAGR(6,16)=22.0
	IMAGR(6,17)=24.0
	IMAGR(20,20)=26.0
	IMAGR(10,10)=28.0

C Input :
	WRITE(6,*)' Input image (real): (max size is 200x200)'
	NAME=' '
	CALL JLP_READIMAG(IMAGR,NX,NY,IDIM,NAME,COMMENTS)

C Option:
        II = 0
        IF(II.NE.0) THEN
19	WRITE(6,15)
15	FORMAT(' Options: ',/,
     1	' 1=direct FFT (output=real,imaginary)',/,
     1	' -1=inverse FFT (output=real,imaginary)',/,
     1	' 2=direct FFT (output=power,phase)',/,
     1	' -2=inverse FFT (output=power,phase)',/,
     1	' Enter your choice:')
	READ(5,*) KOD
	ENDIF

	KOD=1
	IF((IABS(KOD).NE.1).AND.(IABS(KOD).NE.2))THEN
	   WRITE(6,17)
17	   FORMAT(' Error: enter again the option')
	   GOTO 19
	ENDIF

C Imaginary part:
	IF(KOD.LT.0)THEN
	  WRITE(6,*)' Input image (imaginary part):'
	  NAME=' '
	  CALL JLP_READIMAG(IMAGI,NX1,NY1,IDIM,NAME,COMMENTS)
	  IF((NX.NE.NX1).OR.(NY.NE.NY1))THEN
	    WRITE(2,21)
	    WRITE(6,21)
21	    FORMAT(' FATAL ERROR: Wrong size for the input image')
            STOP
	  ENDIF
	ELSE
	  DO J=1,NY
	   DO I=1,NX
	    IMAGI(I,J)=0.
	   ENDDO
	  ENDDO
	ENDIF

	WRITE(6,*) IMAGR(6,16),IMAGR(6,17),IMAGR(20,20),IMAGR(20,21)
	WRITE(6,*) IMAGI(6,16),IMAGI(6,17),IMAGI(20,20),IMAGI(20,21)

C FFT:
	PRINT *,' Normal fourier : 0, else FFT : 1'
	READ(5,*)II
	IF(II.EQ.1)THEN
	  WRITE(6,*) ' Start FFT'
	  CALL FFT_2D(IMAGR,IMAGI,NX,NY,IDIM,KOD)
        ELSE

	DO J=1,NY
	  DO I=1,NX
	    IMAGE(I,J)=IMAGR(I,J)
          END DO
        END DO
	WRITE(6,*) ' Start Fourier Transform'
	ISIGN=1
	CALL JLP_FOURIER(IMAGE,IMAGR,IMAGI,NX,NY,IDIM,ISIGN)
	WRITE(6,*) ' FFT OK'
C        CALL RECENTRE(IMAGR,IMAGR,NX,NY,IDIM)
C        CALL RECENTRE(IMAGI,IMAGI,NX,NY,IDIM)
        ENDIF

	WRITE(6,*) IMAGR(1,1),IMAGR(16,16)
	WRITE(6,*) IMAGI(1,1),IMAGI(16,16)

	WRITE(6,*) IMAGR(6,16),IMAGR(6,17),IMAGR(20,20),IMAGR(20,21)
	WRITE(6,*) IMAGI(6,16),IMAGI(6,17),IMAGI(20,20),IMAGI(20,21)

C Inverse FFT:
	WRITE(6,*) ' Start FFT-1'
	KOD=-1
	CALL FFT_2D(IMAGR,IMAGI,NX,NY,IDIM,KOD)
	WRITE(6,*) ' FFT-1 OK'

	WRITE(6,*) IMAGR(1,1),IMAGR(16,16)
	WRITE(6,*) IMAGI(1,1),IMAGI(16,16)

	WRITE(6,*) IMAGR(6,16),IMAGR(6,17),IMAGR(20,20),IMAGR(20,21)
	WRITE(6,*) IMAGI(6,16),IMAGI(6,17),IMAGI(20,20),IMAGI(20,21)

C        IF (II.EQ.0) STOP
C Output :
	WRITE(6,*)' Real part / Power spect.:'
	NAME=' '
	CALL JLP_WRITEIMAG(IMAGR,NX,NY,IDIM,NAME,COMMENTS)
	WRITE(6,*)' Imaginary part / Phase:'
	NAME=' '
	CALL JLP_WRITEIMAG(IMAGI,NX,NY,IDIM,NAME,COMMENTS)

999	CLOSE(2)
        CALL JLP_END
        STOP
	END
C**********************************************************************
C Interface routine with fourier or fourier1 from d_utilities.for
C**********************************************************************
	SUBROUTINE FFT_2D1(IMAGR,IMAGI,NX,NY,IDIM,KOD)
	REAL IMAGR(IDIM,*),IMAGI(IDIM,*)
        INTEGER P_R,P_I,NX,NY,KOD,NSIZE,IOP
	INTEGER MADRID(1)
	COMMON /MADRID/MADRID

	NSIZE=NX*NY*8
	CALL JLP_GETVM(P_R,NSIZE)
	CALL JLP_GETVM(P_I,NSIZE)

C Transfer to double precision:
        CALL TTO8(MADRID(P_R),IMAGR,NX,NY,IDIM)
        CALL TTO8(MADRID(P_I),IMAGI,NX,NY,IDIM)

C Calling actual FFT now:
	IF(KOD.GT.0)THEN
   	  IOP=1
	ELSE
	  IOP=-1
	ENDIF
        CALL FOURIER1(MADRID(P_R),MADRID(P_I),NX,NY,IOP)

C Transfer back to simple precision:
        CALL FRO8(IMAGR,MADRID(P_R),NX,NY,IDIM)
        CALL FRO8(IMAGI,MADRID(P_I),NX,NY,IDIM)
	CALL JLP_FREEVM(P_R,NSIZE)
	CALL JLP_FREEVM(P_I,NSIZE)

	RETURN
	END
C**********************************************************************
         SUBROUTINE TTO8(BR8,BR4,NX,NY,IDIM)
         REAL BR4(IDIM,*)
	 DOUBLE PRECISION BR8(NX,NY)
	 DO J=1,NY
	   DO I=1,NX
	     BR8(I,J)=DBLE(BR4(I,J))
	   END DO
	 END DO
         RETURN
	 END
C**********************************************************************
         SUBROUTINE FRO8(BR4,BR8,NX,NY,IDIM)
         REAL BR4(IDIM,*)
	 DOUBLE PRECISION BR8(NX,NY)
	 DO J=1,NY
	   DO I=1,NX
	     BR4(I,J)=SNGL(BR8(I,J))
	   END DO
	 END DO
         RETURN
	 END
C********************************************************
	include 'hrsa:fft_jlp.for'
	include 'hrsa:jlp_fourier.for'
C********************************************************
C	include 'hrsa:fft_nag.for'
C********************************************************
	include 'hrsa:d_utilities.for'


*DECK SSPEV
      SUBROUTINE SSPEV (A, N, E, V, LDV, WORK, JOB, INFO)
C***BEGIN PROLOGUE  SSPEV
C***PURPOSE  Compute the eigenvalues and, optionally, the eigenvectors
C            of a real symmetric matrix stored in packed form.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4A1
C***TYPE      SINGLE PRECISION (SSPEV-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK, PACKED, SYMMETRIC
C***AUTHOR  Kahaner, D. K., (NBS)
C           Moler, C. B., (U. of New Mexico)
C           Stewart, G. W., (U. of Maryland)
C***DESCRIPTION
C
C     Abstract
C      SSPEV computes the eigenvalues and, optionally, the eigenvectors
C      of a real symmetric matrix stored in packed form.
C
C     Call Sequence Parameters-
C       (The values of parameters marked with * (star) will be  changed
C         by SSPEV.)
C
C        A*      REAL(N*(N+1)/2)
C                real symmetric packed input matrix.  Contains upper
C                triangle and diagonal of A, by column (elements
C                11, 12, 22, 13, 23, 33, ...).
C
C        N       INTEGER
C                set by the user to
C                the order of the matrix A.
C
C        E*      REAL(N)
C                on return from SSPEV, E contains the eigenvalues of A.
C                See also INFO below.
C
C        V*      REAL(LDV,N)
C                on return from SSPEV, if the user has set JOB
C                = 0        V is not referenced.
C                = nonzero  the N eigenvectors of A are stored in the
C                first N columns of V.  See also INFO below.
C
C        LDV     INTEGER
C                set by the user to
C                the leading dimension of the array V if JOB is also
C                set nonzero.  In that case, N must be .LE. LDV.
C                If JOB is set to zero, LDV is not referenced.
C
C        WORK*   REAL(2N)
C                temporary storage vector.  Contents changed by SSPEV.
C
C        JOB     INTEGER
C                set by the user to
C                = 0        eigenvalues only to be calculated by SSPEV.
C                           Neither V nor LDV are referenced.
C                = nonzero  eigenvalues and vectors to be calculated.
C                           In this case, A & V must be distinct arrays.
C                           Also, if LDA .GT. LDV, SSPEV changes all the
C                           elements of A thru column N.  If LDA < LDV,
C                           SSPEV changes all the elements of V through
C                           column N.  If LDA=LDV, only A(I,J) and V(I,
C                           J) for I,J = 1,...,N are changed by SSPEV.
C
C       INFO*   INTEGER
C               on return from SSPEV, the value of INFO is
C               = 0 for normal return.
C               = K if the eigenvalue iteration fails to converge.
C                   Eigenvalues and vectors 1 through K-1 are correct.
C
C
C     Error Messages-
C          No. 1   recoverable  N is greater than LDV and JOB is nonzero
C          No. 2   recoverable  N is less than one
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  IMTQL2, TQLRAT, TRBAK3, TRED3, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800808  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  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   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C***END PROLOGUE  SSPEV
      INTEGER I,INFO,J,LDV,M,N
      REAL A(*),E(*),V(LDV,*),WORK(*)
C***FIRST EXECUTABLE STATEMENT  SSPEV
       IF (N .GT. LDV) CALL XERMSG ('SLATEC', 'SSPEV', 'N .GT. LDV.',
     +    1, 1)
       IF(N .GT. LDV) RETURN
       IF (N .LT. 1) CALL XERMSG ('SLATEC', 'SSPEV', 'N .LT. 1', 2, 1)
       IF(N .LT. 1) RETURN
C
C       CHECK N=1 CASE
C
      E(1) = A(1)
      INFO = 0
      IF(N .EQ. 1) RETURN
C
      IF(JOB.NE.0) GO TO 20
C
C     EIGENVALUES ONLY
C
      CALL TRED3(N,1,A,E,WORK(1),WORK(N+1))
      CALL TQLRAT(N,E,WORK(N+1),INFO)
      RETURN
C
C     EIGENVALUES AND EIGENVECTORS
C
   20 CALL TRED3(N,1,A,E,WORK(1),WORK(1))
      DO 30 I = 1, N
        DO 25 J = 1, N
   25     V(I,J) = 0.
   30   V(I,I) = 1.
      CALL IMTQL2(LDV,N,E,WORK,V,INFO)
      M = N
      IF(INFO .NE. 0) M = INFO - 1
      CALL TRBAK3(LDV,N,1,A,M,V)
      RETURN
      END


module randomf
    use curand
    use parameters
    use, intrinsic :: iso_fortran_env, only: output_unit

    implicit none

    real, parameter, private :: sqrt3 = sqrt(3.0)

    public initialize_rng, fill_vec
contains
    subroutine initialize_rng(rng)
        type(curandGenerator), intent(inout) :: rng

        ! Local variables
        real :: some_seed
        integer, allocatable :: seed(:)
        integer :: host_seed, istat, largest, io, n

        ! Initialize PRNG
        call random_seed(size=n)
        allocate(seed(n))
        ! Read from urandom file
        open(newunit=io, file="/dev/urandom", access="stream", form="unformatted", &
            action="read", status="old", iostat=istat)
        if (istat==0) then
            read(io, iostat=istat) seed
            close(io)
        endif
        ! Set the final seed
        call random_seed(put=seed)
        ! Initialize the PRNG for the device
        istat = curandCreateGenerator(rng, CURAND_RNG_PSEUDO_DEFAULT)
        ! Compute the seed for the largest 32-bit integer
        call random_number(some_seed)
        host_seed = floor(some_seed * huge(largest))
        ! Show the seed to screen
        write(unit=output_unit, fmt='(a,i)') 'Random seed =', host_seed
        istat = curandSetPseudoRandomGeneratorSeed(rng, host_seed)
        if ( istat .ne. 0 ) then
            write(unit=output_unit, fmt='(a)') 'Error with GPU!'
        end if

    end subroutine initialize_rng

    subroutine fill_vec(vec, rng, threenp)
        real, device, intent(inout) :: vec(:)
        type(curandGenerator), intent(in) :: rng
        integer, intent(in) :: threenp

        ! Local variables
        integer :: istat, i

        ! Initialize the vectors using a uniform distribution
        istat = curandGenerateUniform(rng, vec, threenp)
        if ( istat .ne. 0 ) then
            write(unit=output_unit, fmt='(a)') 'Error with GPU!'
        end if

        ! Move the distribution to (-1, 1)
        ! Multiply by sqrt(6.0 * deltat) to make the second moment
        ! equal as in a normal distribution

        !$cuf kernel do <<< *,* >>>
        do i = 1, threenp
            vec(i) = sqrt3 * sqtwodt * ((2.0 * vec(i)) - 1.0)
        end do
    end subroutine fill_vec

    subroutine fill_vec_normal(vec, rng, threenp)
        real, device, intent(inout) :: vec(:)
        type(curandGenerator), intent(in) :: rng
        integer, intent(in) :: threenp

        ! Local variables
        integer :: istat, i

        ! Initialize the vectors using a uniform distribution
        istat = curandGenerateNormal(rng, vec, threenp, 0.0, sqtwodt)
        if ( istat .ne. 0 ) then
            write(unit=output_unit, fmt='(a)') 'Error with GPU!'
        end if
    end subroutine fill_vec_normal
end module randomf


       SUBROUTINE W3FC02(FFID,FFJD,FGU,FGV,DIR,SPD)
C$$$   SUBPROGRAM  DOCUMENTATION  BLOCK
C
C SUBPROGRAM: W3FC02         GRID U,V WIND COMPS. TO DIR. AND SPEED
C   AUTHOR: STACKPOLE, J.    ORG: W324       DATE: 81-12-30
C
C ABSTRACT: GIVEN THE GRID-ORIENTED WIND COMPONENTS ON A NORTHERN
C   HEMISPHERE POLAR STEREOGRAPHIC GRID POINT, COMPUTE THE DIRECTION
C   AND SPEED OF THE WIND AT THAT POINT.  INPUT WINDS AT THE NORTH
C   POLE POINT ARE ASSUMED TO HAVE THEIR COMPONENTS FOLLOW THE WMO
C   STANDARDS FOR REPORTING WINDS AT THE NORTH POLE.
C   (SEE OFFICE NOTE 241 FOR WMO DEFINITION). OUTPUT DIRECTION
C   WILL FOLLOW WMO CONVENTION.
C
C PROGRAM HISTORY LOG:
C   81-12-30  J.STACKPOLE
C   89-01-20  R.E.JONES  CONVERT TO MICROSOFT FORTRAN 4.10
C   90-06-11  R.E.JONES  CONVERT TO SUN FORTRAN 1.3
C   91-03-30  R.E.JONES  CONVERT TO SiliconGRaphics FORTRAN
C   93-03-29  R.E.JONES  ADD SAVE STATEMENT
C   95-08-09  R.E.JONES  COMPILE ON CRAY
C
C USAGE:  CALL W3FC02 (FFID, FFJD, FGU, FGV, DIR, SPD)
C
C   INPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     FFID   ARG LIST  REAL*4    I(NORTH POLE) - I(POINT)
C     FFJD   ARG LIST  REAL*4    J(NORTH POLE) - J(POINT)
C     FGU    ARG LIST  REAL*4    GRID-ORIENTED U-COMPONENT
C     FGV    ARG LIST  REAL*4    GRID-ORIENTED V-COMPONENT
C
C   OUTPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     DIR    ARG LIST  REAL*4     WIND DIRECTION, DEGREES
C     SPD    ARG LIST  REAL*4     WIND SPEED
C
C   SUBPROGRAMS CALLED:
C     NAMES                                                   LIBRARY
C     ------------------------------------------------------- --------
C     ABS  ACOS   ATAN2   SQRT                                SYSTEM
C
C WARNING: THIS JOB WILL NOT VECTORIZE ON A CRAY
C
C ATTRIBUTES:
C   LANGUAGE: CRAY CFT77 FORTRAN
C   MACHINE:  CRAY C916/16256, J916/162048
C
C$$$
C
      SAVE
C
      SPD = SQRT(FGU * FGU + FGV * FGV)
      IF (SPD.NE.0.) GO TO 1000
         FGU = 0.
         FGV = 0.
         GO TO 3000
 1000 CONTINUE
      DFP = SQRT(FFID * FFID + FFJD * FFJD)
      IF (DFP.NE.0.) GO TO 2000
         XLAM = ACOS(FGU / SPD)
         XLAM = XLAM * 57.29578
         IF (FGV.LT.0.) DIR = 170. + XLAM
         IF ((FGV.GT.0.).AND.(XLAM.LT.170.)) DIR = 170. - XLAM
         IF ((FGV.GT.0.).AND.(XLAM.GE.170.)) DIR = 530. - XLAM
         IF ((ABS(FGV).LE.0.001).AND.(FGU.GT.0.)) DIR = 170.
         IF ((ABS(FGV).LE.0.001).AND.(FGU.LT.0.)) DIR = 350.
         GO TO 3000
 2000 CONTINUE
         CAL = FFJD / DFP
         SAL = FFID / DFP
         U = FGU * CAL - FGV * SAL
         V = FGU * SAL + FGV * CAL
         DIR = 57.29578 * ATAN2(U,V) + 180.
 3000 CONTINUE
      RETURN
      END