	SUBROUTINE CV_PRMT ( np, xpt, ypt, dens, maxpts, crvscl,
     +			     istrt, iend, nout, xcv, ycv, iret )
C************************************************************************
C* CV_PRMT								*
C*									*
C* This subroutine performs a parametric curve fit to NP data points.	*
C* ISTRT and IEND define the range of points to return in XCV and YCV.	*
C* If ISTRT and IEND are outside of the number of original points, then	*
C* all the new points are returned.  Otherwise, the curve between ISTRT	*
C* and IEND is returned.						*
C*									*
C* "Parametric curve fitting:  An alternative to Lagrange interpolation	*
C* and splines", Y. Akyildiz, Computers in Physics, Vol 8, No 6,	*
C* Nov/Dec 1994, pp 722-729.						*
C*									*
C* CV_PRMT ( NP, XPT, YPT, DENS, MAXPTS, CRVSCL, ISTRT, IEND,		*
C*	     NOUT, XCV, YCV, IRET )					*
C*									*
C* Input parameters:							*
C*	NP		INTEGER		Number of input points		*
C*	XPT (NP)	REAL		X input coordinates		*
C*	YPT (NP)	REAL		Y input coordinates		*
C*	DENS		REAL		Density of intermediate points	*
C*	MAXPTS		INTEGER		Maximum number of output points	*
C*	CRVSCL		REAL		Device curve scaling factor	*
C*	ISTRT		INTEGER		Start of segment to return	*
C*	IEND		INTEGER		End of segment to return	*
C*									*
C* Output parameters:							*
C*	NOUT		INTEGER		Number of output points		*
C*	XCV (NOUT)	REAL		X evaluated coordinates		*
C*	YCV (NOUT)	REAL		Y evaluated coordinates		*
C*	IRET		INTEGER		Return code			*
C*									*
C**									*
C* S. Jacobs/NCEP	 4/98						*
C* S. Jacobs/NCEP	 4/98	Fixed a bug with short segments		*
C* S. Jacobs/NCEP	 7/98	Added MAXPTS to call seq and checks	*
C* T. Lee/GSC		 7/98	Renamed DPRMTC; Added CRVSCL to	call seq*
C* S. Jacobs/NCEP	 8/98	Added ISTRT & IEND to calling sequence	*
C* S. Jacobs/NCEP	 9/98	Do not comp curve if <= 2 unique points	*
C* T. Piper/GSC		 3/99	Corrected prolog			*
C* S. Jacobs/NCEP	 5/99	Fixed calc of num of pts per sub-segment*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		xpt (*), ypt (*), xcv (*), ycv (*)
C*
	INTEGER		npt (LLMXPT)
	REAL		xtmp(0:LLMXPT), ytmp(0:LLMXPT)
C------------------------------------------------------------------------
	iret = 0
C
C*	Get the start and end points of the return segment.
C
	kstrt = istrt
	kend  = iend
	IF  ( ( kstrt .lt. 1 ) .or. ( kstrt .gt. np ) )  kstrt = 1
	IF  ( ( kend  .lt. 1 ) .or. ( kend  .gt. np ) )  kend  = np
	IF  ( kstrt .ge. kend )  THEN
	    kstrt = 1
	    kend  = np
	END IF
C
C*	Check for identical points and eliminate.
C
	k = 1
	xtmp(k) = xpt(1)
	ytmp(k) = ypt(1)
	jstrt = kstrt
	jend  = kend
C
	DO  i = 2, np
	    IF  ( ( xtmp(k) .eq. xpt(i) ) .and.
     +		  ( ytmp(k) .eq. ypt(i) ) ) THEN
		IF  ( kstrt .ge. i )  jstrt = jstrt - 1
		IF  ( kend  .ge. i )  jend  = jend  - 1
	      ELSE
		k = k + 1
		xtmp(k) = xpt(i)
		ytmp(k) = ypt(i)
	    END IF
	END DO
	ntmp = k
C
C*	Check for all points the same.
C
	IF  ( ntmp .le. 2 )  THEN
	    DO  m = 1, np
		xcv(m) = xpt(m)
		ycv(m) = ypt(m)
	    END DO
	    nout = np
	    RETURN
	END IF
C
C*	Get the number of intermediate points for each segment.
C*	Compute the chord length of each segment.
C
	nout = 0
	DO  i = 1, ntmp-1
	    chord  = SQRT ( (xtmp(i+1)-xtmp(i))**2 +
     +			    (ytmp(i+1)-ytmp(i))**2 )
	    npt(i) = INT ( chord / ( crvscl / dens ) ) + 1
	    nout = nout + npt(i)
	END DO
	nout = nout + ntmp
C
C*	If the number of output points is greater than the max allowed,
C*	set the output points to the input points and return.
C
	IF  ( nout .gt. maxpts )  THEN
	    iret = -1
	    DO  m = 1, np
		xcv(m) = xpt(m)
		ycv(m) = ypt(m)
	    END DO
	    nout = np
	    RETURN
	END IF
C
C*	Get the addtional end points, if necessary.
C
	IF  ( ( xtmp(1) .eq. xtmp(ntmp) ) .and.
     +	      ( ytmp(1) .eq. ytmp(ntmp) ) )  THEN
	    xtmp(0) = xtmp(ntmp-1)
	    ytmp(0) = ytmp(ntmp-1)
	    xtmp(ntmp+1) = xtmp(2)
	    ytmp(ntmp+1) = ytmp(2)
	  ELSE
	    xtmp(0) = ( 5*xtmp(1) - 4*xtmp(2) + xtmp(3) ) / 2.0
	    ytmp(0) = ( 5*ytmp(1) - 4*ytmp(2) + ytmp(3) ) / 2.0
	    xtmp(ntmp+1) = ( 5*xtmp(ntmp) - 4*xtmp(ntmp-1) +
     +			     xtmp(ntmp-2) ) / 2.0
	    ytmp(ntmp+1) = ( 5*ytmp(ntmp) - 4*ytmp(ntmp-1) +
     +			     ytmp(ntmp-2) ) / 2.0
	END IF
C
C*	Find the points for the smooth curve.
C
	xcv (1) = xtmp(jstrt)
	ycv (1) = ytmp(jstrt)
	m = 1
	DO  k = jstrt, jend-1
	    DO  j = 1, npt(k)
		t = FLOAT(j) / FLOAT(npt(k))
		m = m + 1
		xcv(m) = xtmp(k)
     +			 + 0.5*(xtmp(k+1)-xtmp(k-1))*t
     +			 - 0.5*(xtmp(k+2)-4*xtmp(k+1)+
     +			        5*xtmp(k)-2*xtmp(k-1))*(t**2)
     +			 + 0.5*(xtmp(k+2)-3*xtmp(k+1)+
     +			        3*xtmp(k)-xtmp(k-1))*(t**3)
		ycv(m) = ytmp(k)
     +			 + 0.5*(ytmp(k+1)-ytmp(k-1))*t
     +			 - 0.5*(ytmp(k+2)-4*ytmp(k+1)+
     +			        5*ytmp(k)-2*ytmp(k-1))*(t**2)
     +			 + 0.5*(ytmp(k+2)-3*ytmp(k+1)+
     +			        3*ytmp(k)-ytmp(k-1))*(t**3)
	    END DO
	END DO
	nout = m
C*
	RETURN
	END


!> \brief Compute the mass flux in the y direction, cv
!! \detail Given the current pressure and velocity fields,
!! computes the mass flux in the y direction.
module compute_cv_mod
  use kind_params_mod
  use kernel_mod
  use argument_mod
  use grid_mod
  use field_mod
  implicit none

  private

  public invoke_compute_cv
  public compute_cv, compute_cv_code

  type, extends(kernel_type) :: compute_cv
     type(go_arg), dimension(3) :: meta_args =    &
          (/ go_arg(GO_WRITE, GO_CV, GO_POINTWISE),        & ! cv
             go_arg(GO_READ,  GO_CT, GO_POINTWISE),        & ! p
             go_arg(GO_READ,  GO_CV, GO_POINTWISE)         & ! v
           /)
     !> This kernel writes only to internal points of the
     !! simulation domain.
     integer :: ITERATES_OVER = GO_INTERNAL_PTS

     !> Although the staggering of variables used in an Arakawa
     !! C grid is well defined, the way in which they are indexed is
     !! an implementation choice. This can be thought of as choosing
     !! which grid-point types have the same (i,j) index as a T
     !! point. This kernel assumes that the U,V and F points that
     !! share the same index as a given T point are those immediately
     !! to the South and West of it.
     integer :: index_offset = GO_OFFSET_SW

  contains
    procedure, nopass :: code => compute_cv_code
  end type compute_cv

contains

  !===================================================

  !> Manual implementation of the code needed to invoke
  !! compute_cv_code().
  subroutine invoke_compute_cv(cvfld, pfld, vfld)
    implicit none
    type(r2d_field), intent(inout) :: cvfld
    type(r2d_field), intent(in)    :: pfld, vfld
    ! Locals
    integer :: I, J

    ! Note that we do not loop over the full extent of the field.
    ! Fields are allocated with extents (M+1,N+1).
    ! Presumably the extra row and column are needed for periodic BCs.
    ! We are updating a quantity on CV.
    ! This loop writes to cv(1:M,2:N+1) so this looks like
    ! (using x to indicate a location that is written):
    !
    ! i=1   i=M
    !  x  x  x  o
    !  x  x  x  o   j=N
    !  x  x  x  o
    !  o  o  o  o   j=1

    ! Quantity CV is mass flux in y direction.

    ! Original code looked like:
    !
    !    DO J=1,N
    !      DO I=1,M
    !           CV(I,J+1) = .5*(P(I,J+1)+P(I,J))*V(I,J+1)
    !      END DO
    !    END DO

    ! cv(i,j) depends upon:
    !   p(i,j-1), p(i,j) : CT
    !    => vertical CT neighbours of the CV pt being updated
    !   v(i,j)           : CV
    !    => the velocity component at the CV pt being updated

    !   vi-1j+1--fij+1---vij+1---fi+1j+1
    !   |        |       |       |
    !   |        |       |       |
    !   Ti-1j----uij-----Tij-----ui+1j
    !   |        |       |       |
    !   |        |       |       |
    !   vi-1j----fij-----vij-----fi+1j
    !   |        |       |       |
    !   |        |       |       |
    !   Ti-1j-1--uij-1---Tij-1---ui+1j-1
    !

    do J=cvfld%internal%ystart, cvfld%internal%ystop
       do I=cvfld%internal%xstart, cvfld%internal%xstop

          call compute_cv_code(i, j, cvfld%data, pfld%data, vfld%data)
       end do
    end do

  end subroutine invoke_compute_cv

  !===================================================

  !> Compute the mass flux in the y direction at point (i,j)
  subroutine compute_cv_code(i, j, cv, p, v)
    implicit none
    integer,  intent(in) :: I, J
    real(go_wp), intent(out), dimension(:,:) :: cv
    real(go_wp), intent(in),  dimension(:,:) :: p, v

    CV(I,J) = .5d0*(P(I,J)+P(I,J-1))*V(I,J)

  end subroutine compute_cv_code

end module compute_cv_mod


      FUNCTION CHABIMF(ALO,AUP,M1,M2,STARMASS)

c     Returns number of stars in range from M1 to M2 for Chabrier (2001) IMF
c     Returns the mass in stars from M1 to M2
c     ALO and AUP are the lower and upper cutoffs of the IMF, which
c     is normalized to 1 Mo over this range

      implicit real (A-H,O-Z)
      real*8 m1,m2,starmass

      common /fmlog/xml,sigmac,anormlog
      common /fmlin/anormlin

*******************************************************
*                 - Adjustable parameters -
*
*    Lower and upper masses for the entire mass
*    integration of the IMF: alo, aup
*    Index "alpha=1+x" in the power-law part > 1 Msol
*           dn/dm propto m**(-alpha)
      alpha=2.3
*******************************************************

      xml=-1.1
      sigmac=0.69
      call chabint(alo,aup,alpha)    ! calculates the normalization
      al1=1.-alpha
      al2=2.-alpha
      anorm=anormlin/log(10.)
      v1log=anormlog*exp(-xml**2/2./sigmac**2)
c      print*,'normlog, normlin',anormlog,anormlin
c      print*,'norm @ 1 Msol',v1log,anormlin
      if(v1log.ne.anormlin) then
                            print*,'normalization pb in routine chabimf!'
                            stop
      endif

	if (m2.le.m1) then
		chabimf=0.
		starmass=0.
		return
	endif

      IF(m1.LE.1.0) THEN
            if(m2.LE.1.0) then
                vnum=chabnum(m1,m2)     ! number-density
                vmas=chabmas(m1,m2)     ! mass-density
            else
                alim=1.0
                vnum=chabnum(m1,dble(alim))+anorm/al1*(m2**al1-1.0)
                vmas=chabmas(m1,dble(alim))+anorm/al2*(m2**al2-1.0)
            endif
      ELSE
                vnum=anorm/al1*(m2**al1-m1**al1)
                vmas=anorm/al2*(m2**al2-m1**al2)
      ENDIF

      chabimf=vnum
      starmass=vmas

      return
      end

      SUBROUTINE CHABINT(alo,aup,alpha)
**************************************************************************
**    chabmas calculates the normalization such that
**        [int m.(dn/dm)dm = 1]  from m=alo to m=aup
**************************************************************************
      implicit real (A-H,O-Z)
      common /fmlog/xml,sigmac,anormlog
      common /fmlin/anormlin

      pi=4.*atan(1.)
      cte2=exp(-xml**2/sigmac**2/2.)
      al2=2.-alpha
      clin=cte2/al2*(aup**al2-1.)
      if(aup.LE.1.) clin=0.

      sigmacp=sigmac*log(10.)
      xmlp=xml*log(10.)
      cte1=exp(xmlp+sigmacp**2/2.)
      x1=-(xmlp+sigmacp**2)/sqrt(2.)/sigmacp
      xlo=(log10(alo)*log(10.)-(xmlp+sigmacp**2))/sqrt(2.)/sigmacp
      clog=cte1*sqrt(2.*pi)/2.*sigmacp
     !       *  (erf(x1) - erf(xlo))

      anorm=1./(clog+clin)
      anormlog=anorm*log(10.)     ! cte de la partie lognormal
      anormlin=anormlog*cte2         ! cte de la partie loi de puissance

      return
      end

      FUNCTION CHABNUM(xmin,xmax)
**************************************************************************
**                         *    IMF Chabrier   *
**    chabnum returns [int (dn/dm)dm]  from m=xmin to m=xmax
*************************************************************************
      implicit real (A-H,O-Z)
	real*8 xmin,xmax
c	real*8 y1,y2,de
	include 'chabimf.dec'
      common /fmlog/xml,sigmac,anormlog

c	check mass range
	if (xmax.le.xmin) then
		chabnum=0.
		return
	else
		pi=4.*atan(1.)
c		Modified by GBA, April 19, 2003
c		chabnum=anormlog * sqrt(2.*pi)/2.*sigmac
c    !		*( erf((log10(xmax)-xml)/sqrt(2.)/sigmac )
c    !		-  erf((log10(xmin)-xml)/sqrt(2.)/sigmac ) )
		y1 =  (dlog10(xmax*1.D00)-xml)/sqrt(2.)/sigmac
		y2 =  (dlog10(xmin*1.D00)-xml)/sqrt(2.)/sigmac
		de =  erf(y1) - erf(y2)
		chabnum=anormlog * sqrt(2.*pi)/2.*sigmac * de
		return
	endif
	end

      FUNCTION CHABMAS(xmin,xmax)
**************************************************************************
**                         *    IMF Chabrier   *
**    chabmas returns [int m.(dn/dm)dm]  from m=xmin to m=xmax
*************************************************************************
      implicit real (A-H,O-Z)
	real*8 xmin,xmax
c	real*8 y1,y2,de
	include 'chabimf.dec'
      common /fmlog/xml,sigmac,anormlog

c	Check mass range
	if (xmax.le.xmin) then
		chabmas=0.
		return
	else
		pi=4.*atan(1.)
		sigmacp=log(10.)*sigmac
		xmlp=xml*log(10.)
		anormp=anormlog/log(10.)
		cte=exp(xmlp+sigmacp**2/2.)
c		Modified by GBA, April 19, 2003
c		x1=(log10(xmin)*log(10.)-(xmlp+sigmacp**2))/sqrt(2.)/sigmacp
c		x2=(log10(xmax)*log(10.)-(xmlp+sigmacp**2))/sqrt(2.)/sigmacp
c		chabmas=anormp*cte*sqrt(2.*pi)/2.*sigmacp * (erf(x2) - erf(x1))
		y1=(dlog10(xmin*1.D00)*dlog(10.D00)-(xmlp+sigmacp**2))/sqrt(2.)/sigmacp
		y2=(dlog10(xmax*1.D00)*dlog(10.D00)-(xmlp+sigmacp**2))/sqrt(2.)/sigmacp
		de=erf(y2) - erf(y1)
		chabmas=anormp * cte * sqrt(2.*pi)/2.*sigmacp * de
		return
	endif
	end


! { dg-do run }
! { dg-options "-fcheck=all" }
!
! Basic check of Parameterized Derived Types.
!
! -fcheck=all is used here to ensure that when the parameter
! 'b' of the dummy in 'foo' is assumed, there is no error.
! Likewise in 'bar' and 'foobar', when 'b' has the correct
! explicit value.
!
  implicit none
  integer, parameter :: ftype = kind(0.0e0)
  integer :: pdt_len = 4
  integer :: i
  type :: mytype (a,b)
    integer, kind :: a = kind(0.0d0)
    integer, LEN :: b
    integer :: i
    real(kind = a) :: d(b, b)
    character (len = b*b) :: chr
  end type

  type(mytype(b=4)) :: z(2)
  type(mytype(ftype, 4)) :: z2

  z(1)%i = 1
  z(2)%i = 2
  z(1)%d = reshape ([(real(i), i = 1, 16)],[4,4])
  z(2)%d = 10*z(1)%d
  z(1)%chr = "hello pdt"
  z(2)%chr = "goodbye pdt"

  z2%d = z(1)%d * 10 - 1
  z2%chr = "scalar pdt"

  call foo (z)
  call bar (z)
  call foobar (z2)
contains
  elemental subroutine foo (arg)
    type(mytype(8,*)), intent(in) :: arg
    if (arg%i .eq. 1) then
      if (trim (arg%chr) .ne. "hello pdt") error stop
      if (int (sum (arg%d)) .ne. 136) error stop
    else if (arg%i .eq. 2 ) then
      if (trim (arg%chr) .ne. "goodbye pdt") error stop
      if (int (sum (arg%d)) .ne. 1360) error stop
    else
      error stop
    end if
  end subroutine
  subroutine bar (arg)
    type(mytype(b=4)) :: arg(:)
    if (int (sum (arg(1)%d)) .ne. 136) STOP 1
    if (trim (arg(2)%chr) .ne. "goodbye pdt") STOP 2
  end subroutine
  subroutine foobar (arg)
    type(mytype(ftype, pdt_len)) :: arg
    if (int (sum (arg%d)) .ne. 1344) STOP 3
    if (trim (arg%chr) .ne. "scalar pdt") STOP 4
  end subroutine
end


program integration2

  implicit none

  integer :: i, j
  real(8) :: x, y, userfunc
  real(8), dimension(10, 10) :: integ

  external userfunc

  integ = 0.0d0

  open(unit=1, file='integration2.dat', action='write')

  write(1, *) integ

  do j = 1, 10

     y = dble(j) * 1.0d0

     do i = 1, 10

        x = dble(i) * 0.25d0

        integ(i, j) = userfunc(x, y)

        write(1, *) integ(i, j)

     end do

  end do

  close(1)

  write(*,'(a,e20.10e3)') 'Integration value = ', sum(integ)

end program integration2


      program main

c*********************************************************************72
c
cc MAIN is the main program for BLAS1_C_PRB.
c
c  Discussion:
c
c    BLAS1_C_PRB tests the BLAS1_C library.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    15 May 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      call timestamp ( )
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'BLAS1_C_PRB:'
      write ( *, '(a)' ) '  FORTRAN77 version'
      write ( *, '(a)' ) '  Test the BLAS1_C library.'

      call test01 ( )
      call test02 ( )
      call test03 ( )
      call test04 ( )
      call test05 ( )
      call test06 ( )
      call test07 ( )
      call test08 ( )
      call test09 ( )

      call test10 ( )
      call test11 ( )
      call test12 ( )
      call test13 ( )
      call test14 ( )
      call test15 ( )
      call test16 ( )
      call test17 ( )
c
c  Terminate.
c
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'BLAS1_C_PRB:'
      write ( *, '(a)' ) '  Normal end of execution.'
      write ( *, '(a)' ) ' '
      call timestamp ( )

      stop
      end
      subroutine test01 ( )

c*********************************************************************72
c
cc TEST01 tests CABS1.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    27 February 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      complex c
      complex c4_uniform_01
      real c_norm
      real cabs1
      integer i
      integer seed

      seed = 123456789

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST01'
      write ( *, '(a)' ) '  CABS1 returns the L1 norm '
      write ( *, '(a)' ) '  of a single precision complex number.'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '      Real      Imaginary              '
      write ( *, '(a)' ) '      Part      Part           CABS1(Z)'
      write ( *, '(a)' ) ' '

      do i = 1, 10

        c = 5.0E+00 * c4_uniform_01 ( seed )

        c_norm = cabs1 ( c )

        write ( *, '(2x,2f10.4,5x,f10.4)' ) c, c_norm

      end do

      return
      end
      subroutine test02 ( )

c*********************************************************************72
c
cc TEST02 tests CABS2.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    14 April 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      complex c
      complex c4_uniform_01
      real c_norm
      real cabs2
      integer i
      integer seed

      seed = 123456789

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST02'
      write ( *, '(a)' ) '  CABS2 returns the L2 norm '
      write ( *, '(a)' ) '  of a single precision complex number.'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '      Real      Imaginary              '
      write ( *, '(a)' ) '      Part      Part           CABS2(Z)'
      write ( *, '(a)' ) ' '

      do i = 1, 10

        c = 5.0E+00 * c4_uniform_01 ( seed )

        c_norm = cabs2 ( c )

        write ( *, '(2x,2f10.4,5x,f10.4)' ) c, c_norm

      end do

      return
      end
      subroutine test03 ( )

c*********************************************************************72
c
cc TEST03 tests CAXPY.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    27 February 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      parameter ( n = 5 )

      integer i
      complex s
      complex x(n)
      complex y(n)

      x(1) = (  2.0E+00, -1.0E+00 )
      x(2) = ( -4.0E+00, -2.0E+00 )
      x(3) = (  3.0E+00,  1.0E+00 )
      x(4) = (  2.0E+00,  2.0E+00 )
      x(5) = ( -1.0E+00, -1.0E+00 )

      y(1) = ( -1.0E+00,  0.0E+00 )
      y(2) = (  0.0E+00, -3.0E+00 )
      y(3) = (  4.0E+00,  0.0E+00 )
      y(4) = ( -3.0E+00,  4.0E+00 )
      y(5) = ( -2.0E+00,  0.0E+00 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST03'
      write ( *, '(a)' ) '  CAXPY adds a multiple of one'
      write ( *, '(a)' ) '  single precision complex vector to another.'

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, x(i)
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  Y = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, y(i)
      end do

      s = ( 0.50E+00, -1.00E+00 )

      write ( *, '(a)' ) ' '
      write ( *, '(a,2g14.6)' ) '  The scalar multiplier is: ', s

      call caxpy ( n, s, x, 1, y, 1 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  A * X + Y = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2f10.6)' ) i, y(i)
      end do

      return
      end
      subroutine test04 ( )

c*********************************************************************72
c
cc TEST04 tests CCOPY.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    01 March 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      complex a(5,5)
      integer i
      integer j
      complex x(10)
      complex y(10)

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST04'
      write ( *, '(a)' ) '  CCOPY copies one complex vector '
      write ( *, '(a)' ) '  into another.'

      do i = 1, 10
        x(i) = cmplx ( 10 * i, i )
      end do

      do i = 1, 10
        y(i) = cmplx ( 20 * i, 2 * i )
      end do

      do i = 1, 5
        do j = 1, 5
          a(i,j) = cmplx ( 10 * i,  j )
        end do
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X = '
      write ( *, '(a)' ) ' '
      do i = 1, 10
        write ( *, '(2x,i6,2g14.6)' ) i, x(i)
      end do
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  Y = '
      write ( *, '(a)' ) ' '
      do i = 1, 10
        write ( *, '(2x,i6,2g14.6)' ) i, y(i)
      end do
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  A = '
      write ( *, '(a)' ) ' '
      do i = 1, 5
        write ( *, '(2x,10f7.1)' ) ( a(i,j), j = 1, 5 )
      end do

      call ccopy ( 5, x, 1, y, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  CCOPY ( 5, X, 1, Y, 1 )'
      write ( *, '(a)' ) ' '
      do i = 1, 10
        write ( *, '(2x,i6,2g14.6)' ) i, y(i)
      end do

      do i = 1, 10
        y(i) = cmplx ( 20 * i, 2 * i )
      end do

      call ccopy ( 3, x, 2, y, 3 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  CCOPY ( 3, X, 2, Y, 3 )'
      write ( *, '(a)' ) ' '
      do i = 1, 10
        write ( *, '(2x,i6,2g14.6)' ) i, y(i)
      end do

      call ccopy ( 5, x, 1, a, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  CCOPY ( 5, X, 1, A, 1 )'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  A = '
      write ( *, '(a)' ) ' '
      do i = 1, 5
        write ( *, '(2x,10f7.1)' ) ( a(i,j), j = 1, 5 )
      end do

      do i = 1, 5
        do j = 1, 5
          a(i,j) = cmplx ( 10 * i,  j )
        end do
      end do

      call ccopy ( 5, x, 2, a, 5 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  CCOPY ( 5, X, 2, A, 5 )'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  A = '
      write ( *, '(a)' ) ' '
      do i = 1, 5
        write ( *, '(2x,10f7.1)' ) ( a(i,j), j = 1, 5 )
      end do

      return
      end
      subroutine test05 ( )

c*********************************************************************72
c
cc TEST05 tests CDOTC.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    01 March 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      parameter ( n = 5 )

      complex cdotc
      integer i
      complex x(n)
      complex x_norm
      complex xy_dot
      complex y(n)

      x(1) = (  2.0E+00, -1.0E+00 )
      x(2) = ( -4.0E+00, -2.0E+00 )
      x(3) = (  3.0E+00,  1.0E+00 )
      x(4) = (  2.0E+00,  2.0E+00 )
      x(5) = ( -1.0E+00, -1.0E+00 )

      y(1) = ( -1.0E+00,  0.0E+00 )
      y(2) = (  0.0E+00, -3.0E+00 )
      y(3) = (  4.0E+00,  0.0E+00 )
      y(4) = ( -3.0E+00,  4.0E+00 )
      y(5) = ( -2.0E+00,  0.0E+00 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST05'
      write ( *, '(a)' ) '  CDOTC computes the conjugated dot product'
      write ( *, '(a)' ) '  of two complex vectors.'

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, x(i)
      end do

      x_norm = cdotc ( n, x, 1, x, 1 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  The square of the norm of X, computed as'
      write ( *, '(a,f10.4,2x,f10.4)' ) '  CDOTC(X,X) = ', x_norm

      xy_dot = cdotc ( n, x, 1, y, 1 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  Y = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, y(i)
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a,f10.4,2x,f10.4)' )
     &  '  The dot product X.Y* is ', xy_dot

      return
      end
      subroutine test06 ( )

c*********************************************************************72
c
cc TEST06 tests CDOTU.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    01 March 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      parameter ( n = 5 )

      complex cdotu
      integer i
      complex x_norm
      complex xy_dot
      complex x(n)
      complex y(n)

      x(1) = (  2.0E+00, -1.0E+00 )
      x(2) = ( -4.0E+00, -2.0E+00 )
      x(3) = (  3.0E+00,  1.0E+00 )
      x(4) = (  2.0E+00,  2.0E+00 )
      x(5) = ( -1.0E+00, -1.0E+00 )

      y(1) = ( -1.0E+00,  0.0E+00 )
      y(2) = (  0.0E+00, -3.0E+00 )
      y(3) = (  4.0E+00,  0.0E+00 )
      y(4) = ( -3.0E+00,  4.0E+00 )
      y(5) = ( -2.0E+00,  0.0E+00 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST06'
      write ( *, '(a)' ) '  CDOTU computes the unconjugated dot product'
      write ( *, '(a)' ) '  of two complex vectors.'

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, x(i)
      end do

      x_norm = cdotu ( n, x, 1, x, 1 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  The unconjugated dot product ( X dot X )'
      write ( *, '(a)' )
     &  '  (which is NOT the square of the norm of X!):'
      write ( *, '(a,f10.4,2x,f10.4)' ) '  CDOTU(X,X) = ', x_norm

      xy_dot = cdotu ( n, x, 1, y, 1 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  Y = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, y(i)
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a,f10.4,2x,f10.4)' )
     &  '  The dot product ( X dot Y ) is ', xy_dot

      return
      end
      subroutine test07 ( )

c*********************************************************************72
c
cc TEST07 tests CMACH.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    01 March 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      real cmach
      integer job

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST07'
      write ( *, '(a)' ) '  CMACH computes several machine-dependent'
      write ( *, '(a)' ) '  complex arithmetic parameters.'

      write ( *, '(a)' ) ' '
      write ( *, * ) '  CMACH(1)  = machine epsilon = ', cmach ( 1 )
      write ( *, * ) '  CMACH(2)  = a tiny value    = ', cmach ( 2 )
      write ( *, * ) '  CMACH(3)  = a huge value    = ', cmach ( 3 )

      return
      end
      subroutine test08 ( )

c*********************************************************************72
c
cc TEST08 tests CROTG.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    15 May 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      complex a
      complex b
      real c
      complex c4_uniform_01
      complex r
      complex s
      complex sa
      complex sb
      integer seed
      integer test
      integer test_num

      test_num = 5

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST08'
      write ( *, '(a)' ) '  CROTG generates a complex Givens rotation'
      write ( *, '(a)' ) '    (  C  S ) * ( A ) = ( R )'
      write ( *, '(a)' ) '    ( -S  C )   ( B )   ( 0 )'
      write ( *, '(a)' ) ' '

      seed = 123456789

      do test = 1, test_num

        a = c4_uniform_01 ( seed )
        b = c4_uniform_01 ( seed )

        sa = a
        sb = b

        call crotg ( sa, sb, c, s )

        r = sa

        write ( *, '(a)' ) ' '
        write ( *, '(a,2g14.6)' ) '  A =  ', a
        write ( *, '(a,2g14.6)' ) '  B =  ', b
        write ( *, '(a, g14.6)' ) '  C =  ', c
        write ( *, '(a,2g14.6)' ) '  S =  ', s
        write ( *, '(a,2g14.6)' ) '  R =  ', r
        write ( *, '(a,2g14.6)' )
     &    '         C *A+S*B = ',          c   * a + s * b
        write ( *, '(a,2g14.6)' )
     &    '  -conjg(S)*A+C*B = ', -conjg ( s ) * a + c * b

      end do

      return
      end
      subroutine test09 ( )

c*********************************************************************72
c
cc TEST09 tests CSCAL.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 March 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      parameter ( n = 6 )

      complex da
      integer i
      complex x(n)

      do i = 1, n
        x(i) = cmplx ( 10 * i, i )
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST09'
      write ( *, '(a)' ) '  CSCAL multiplies a complex scalar '
      write ( *, '(a)' ) '  times a vector.'

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, x(i)
      end do

      da = cmplx ( 5.0E+00, 0.0E+00 )
      call cscal ( n, da, x, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,2f8.4,a)' ) '  CSCAL ( N, (', da, '), X, 1 )'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, x(i)
      end do

      do i = 1, n
        x(i) = cmplx ( 10 * i, i )
      end do

      da = cmplx ( -2.0E+00, 1.0E+00 )
      call cscal ( 3, da, x, 2 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,2f8.4,a)' ) '  CSCAL ( 3, (', da, '), X, 2 )'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, x(i)
      end do

      return
      end
      subroutine test10 ( )

c*********************************************************************72
c
cc TEST10 tests CSIGN1.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 March 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      complex c1
      complex c2
      complex c3
      complex c4_uniform_01
      complex csign1
      integer i
      integer seed

      seed = 123456789

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST10'
      write ( *, '(a)' ) '  CSIGN1 ( C1, C2 ) transfers the sign of'
      write ( *, '(a)' ) '  complex C2 to the CABS1 magnitude of C1.'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' )
     &  '           C1                    C2                    C3'
      write ( *, '(a,a)' )
     &  '  --------------------  --------------------  ',
     &  '--------------------'
      write ( *, '(a)' ) ' '

      do i = 1, 10

        c1 = 5.0E+00 * c4_uniform_01 ( seed )
        c2 = 5.0E+00 * c4_uniform_01 ( seed )
        c3 = csign1 ( c1, c2 )

        write ( *, '(2x,2f10.4,2x,2f10.4,2x,2f10.4)' ) c1, c2, c3

      end do

      return
      end
      subroutine test11 ( )

c*********************************************************************72
c
cc TEST11 tests CSIGN2.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 March 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      complex c1
      complex c2
      complex c3
      complex c4_uniform_01
      complex csign2
      integer i
      integer seed

      seed = 123456789

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST11'
      write ( *, '(a)' ) '  CSIGN2 ( C1, C2 ) transfers the sign of'
      write ( *, '(a)' ) '  complex C2 to the CABS2 magnitude of C1.'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' )
     &  '           C1                    C2                    C3'
      write ( *, '(a,a)' )
     &  '  --------------------  --------------------  ',
     &  '--------------------'
      write ( *, '(a)' ) ' '

      do i = 1, 10

        c1 = 5.0E+00 * c4_uniform_01 ( seed )
        c2 = 5.0E+00 * c4_uniform_01 ( seed )
        c3 = csign2 ( c1, c2 )

        write ( *, '(2x,2f10.4,2x,2f10.4,2x,2f10.4)' ) c1, c2, c3

      end do

      return
      end
      subroutine test12 ( )

c*********************************************************************72
c
cc TEST12 tests CSROT.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    01 March 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      parameter ( n = 6 )

      real c
      integer i
      real s
      complex x(n)
      complex y(n)

      do i = 1, n
        x(i) = cmplx ( 10 * i, i )
      end do

      do i = 1, n
        y(i) = cmplx ( 20 * i, 2 * i )
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST12'
      write ( *, '(a)' ) '  CSROT carries out a Givens rotation'
      write ( *, '(a)' ) '  on a complex vector.'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X and Y'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,2f10.1,2x,2f10.1)' ) i, x(i), y(i)
      end do

      c = 0.5E+00
      s = sqrt ( 1.0E+00 - c * c )
      call csrot ( n, x, 1, y, 1, c, s )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a,f8.4,a)' )
     &  '  CSROT ( N, X, 1, Y, 1, ', c, ',', s, ' )'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,2f10.1,2x,2f10.1)' ) i, x(i), y(i)
      end do

      return
      end
      subroutine test13 ( )

c*********************************************************************72
c
cc TEST13 tests CSSCAL.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 March 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      parameter ( n = 6 )

      real da
      integer i
      complex x(n)

      do i = 1, n
        x(i) = cmplx ( 10 * i, i )
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST13'
      write ( *, '(a)' ) '  CSSCAL multiplies a real scalar '
      write ( *, '(a)' ) '  times a complex vector.'

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, x(i)
      end do

      da = 5.0E+00
      call csscal ( n, da, x, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  CSSCAL ( N, ', da, ', X, 1 )'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, x(i)
      end do

      do i = 1, n
        x(i) = cmplx ( 10 * i, i )
      end do

      da = -2.0E+00
      call csscal ( 3, da, x, 2 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  CSSCAL ( 3, ', da, ', X, 2 )'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, x(i)
      end do

      return
      end
      subroutine test14 ( )

c*********************************************************************72
c
cc TEST14 tests CSWAP.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 March 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      parameter ( n = 5 )

      integer i
      complex x(n)
      complex y(n)

      do i = 1, n
        x(i) = cmplx ( 10 * i, i )
      end do

      do i = 1, n
        y(i) = cmplx ( 20 * i, 2 * i )
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST14'
      write ( *, '(a)' ) '  CSWAP swaps two complex vectors.'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X and Y'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,2f7.1,2x,2f7.1)' ) i, x(i), y(i)
      end do

      call cswap ( n, x, 1, y, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  CSWAP ( N, X, 1, Y, 1 )'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X and Y'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,2f7.1,2x,2f7.1)' ) i, x(i), y(i)
      end do

      do i = 1, n
        x(i) = cmplx ( 10 * i, i )
      end do

      do i = 1, n
        y(i) = cmplx ( 20 * i, 2 * i )
      end do

      call cswap ( 3, x, 2, y, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  CSWAP ( 3, X, 2, Y, 1 )'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X and Y'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,2f7.1,2x,2f7.1)' ) i, x(i), y(i)
      end do

      return
      end
      subroutine test15 ( )

c*********************************************************************72
c
cc TEST15 tests ICAMAX.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    14 April 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n

      parameter ( n = 5 )

      real cabs1
      integer i
      integer icamax
      integer incx
      complex x(n)

      x(1) = (  2.0E+00, -1.0E+00 )
      x(2) = ( -4.0E+00, -2.0E+00 )
      x(3) = (  3.0E+00,  1.0E+00 )
      x(4) = (  2.0E+00,  2.0E+00 )
      x(5) = ( -1.0E+00, -1.0E+00 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST15'
      write ( *, '(a)' ) '  ICAMAX returns the index of maximum '
      write ( *, '(a)' ) '  magnitude;'

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  The entries and CABS1 magnitudes:'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2f8.4,2x,f8.4)' ) i, x(i), cabs1 ( x(i) )
      end do

      incx = 1

      i = icamax ( n, x, incx )

      write ( *, '(a)' ) ' '
      write ( *, '(a,i6)' ) '  The index of maximum magnitude = ', i
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  Note that this is a 1-based index.'
      write ( *, '(a)' ) '  Note that the L1 norm is used.'

      return
      end
      subroutine test16 ( )

c*********************************************************************72
c
cc TEST16 tests SCASUM.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    14 April 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer ma
      integer na
      integer nx

      parameter ( ma = 5 )
      parameter ( na = 4 )
      parameter ( nx = 8 )

      complex a(ma,na)
      integer i
      integer j
      real scasum
      complex x(nx)

      a(1,1) = ( -3.0E+00,  4.0E+00 )
      a(2,1) = (  2.0E+00,  0.0E+00 )
      a(3,1) = (  3.0E+00, -4.0E+00 )
      a(4,1) = (  2.0E+00,  0.0E+00 )
      a(5,1) = (  2.0E+00, -1.0E+00 )
      a(1,2) = ( -1.0E+00,  1.0E+00 )
      a(2,2) = (  0.0E+00,  5.0E+00 )
      a(3,2) = ( -4.0E+00, -2.0E+00 )
      a(4,2) = ( -4.0E+00,  1.0E+00 )
      a(5,2) = ( -4.0E+00, -3.0E+00 )
      a(1,3) = (  0.0E+00, -2.0E+00 )
      a(2,3) = (  1.0E+00,  3.0E+00 )
      a(3,3) = ( -3.0E+00,  3.0E+00 )
      a(4,3) = ( -3.0E+00,  3.0E+00 )
      a(5,3) = ( -1.0E+00, -2.0E+00 )
      a(1,4) = ( -1.0E+00,  2.0E+00 )
      a(2,4) = (  2.0E+00, -4.0E+00 )
      a(3,4) = (  0.0E+00, -1.0E+00 )
      a(4,4) = (  0.0E+00, -1.0E+00 )
      a(5,4) = ( -2.0E+00,  4.0E+00 )

      x(1) = (  2.0E+00, -1.0E+00 )
      x(2) = ( -4.0E+00, -2.0E+00 )
      x(3) = (  3.0E+00,  1.0E+00 )
      x(4) = (  2.0E+00,  2.0E+00 )
      x(5) = ( -1.0E+00, -1.0E+00 )
      x(6) = ( -1.0E+00,  0.0E+00 )
      x(7) = (  0.0E+00, -3.0E+00 )
      x(8) = (  4.0E+00,  0.0E+00 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST16'
      write ( *, '(a)' ) '  SCASUM adds the absolute values of'
      write ( *, '(a)' ) '  elements of a complex vector.'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X = '
      write ( *, '(a)' ) ' '
      do i = 1, nx
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, x(i)
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a,g14.6)' )
     &  '  SCASUM ( NX,   X, 1    ) = ', scasum ( nx,   x, 1 )
      write ( *, '(a,g14.6)' )
     &  '  SCASUM ( NX/2, X, 2    ) = ', scasum ( nx/2, x, 2 )
      write ( *, '(a,g14.6)' )
     &  '  SCASUM ( 2,    X, NX/2 ) = ', scasum ( 2,    x, nx/2 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  Demonstrate with a matrix A:'
      write ( *, '(a)' ) ' '
      do i = 1, ma
        write ( *, '(4(2x,f6.1,2x,f6.1))' ) ( a(i,j), j = 1, na )
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a,g14.6)' )
     &  '  SCASUM ( MA, A(1,2), 1 )   = ', scasum ( ma, a(1,2), 1 )
      write ( *, '(a,g14.6)' )
     &  '  SCASUM ( NA, A(2,1), MA ) = ', scasum ( na, a(2,1), ma )

      return
      end
      subroutine test17 ( )

c*********************************************************************72
c
cc TEST17 tests SCNRM2.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    14 April 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      parameter ( n = 5 )

      integer i
      integer incx
      real norm
      real scnrm2
      complex x(n)

      x(1) = (  2.0E+00, -1.0E+00 )
      x(2) = ( -4.0E+00, -2.0E+00 )
      x(3) = (  3.0E+00,  1.0E+00 )
      x(4) = (  2.0E+00,  2.0E+00 )
      x(5) = ( -1.0E+00, -1.0E+00 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST17'
      write ( *, '(a)' ) '  SCNRM2 returns the Euclidean norm'
      write ( *, '(a)' ) '  of a complex vector.'

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  The vector X:'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '( 2x, i6, 2x, f6.1, 2x, f6.1 )' ) i, x(i)
      end do

      incx = 1
      norm = scnrm2 ( n, x, incx )

      write ( *, '(a)' ) ' '
      write ( *, '(a,g14.6)'    ) '  The L2 norm of X is ', norm

      return
      end


! Copyright (c) 2015 Alex Kramer <kramer.alex.kramer@gmail.com>
! See the LICENSE.txt file at the top-level directory of this distribution.

module numerics
  use progvars

  implicit none

  contains

    subroutine linspace(x_min, x_max, x_arr, dx)
      ! Create a linear space betwen x_min, x_max, store in x_arr

      implicit none

      real(dp), intent(in) :: x_min, x_max
      real(dp), intent(out) :: x_arr(:)
      real(dp), intent(out) :: dx

      integer :: i_x, n_x

      n_x = size(x_arr)
      dx = (x_max - x_min) / n_x

      do i_x = 1, n_x
         x_arr(i_x) = x_min + i_x * dx
      end do

    end subroutine linspace

end module numerics


program five
implicit none
integer::i,n,x(999),y(999),j
write(*,*)"enter n"
read(*,*)n
do i=1,n
read(*,*)x(i)
end do
call numper(x,n,y,j)
do i=1,j
write(*,*)y(i)
end do
write(x,x)j
end program

subroutine numper(x,n,y,j)
implicit none
integer intent(in)::n
integer intent(in)::x(n)
integer,intent(out)::y(n),j
integer::i
y=0
j=1
do i=1,n
if(mod(x(i),2)==0)then
y(j)=x(i)
j=j+1
end if
end do
end subroutine numper

S1-ex5 find even numbers and return of array.f95


! ##################################################################################################################################
! Begin MIT license text.
! _______________________________________________________________________________________________________

! Copyright 2019 Dr William R Case, Jr (dbcase29@gmail.com)

! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
! associated documentation files (the "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to
! the following conditions:

! The above copyright notice and this permission notice shall be included in all copies or substantial
! portions of the Software and documentation.

! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
! _______________________________________________________________________________________________________

! End MIT license text.

      SUBROUTINE REDUCE_MGG_TO_MNN ( PART_VEC_G_NM )

! Call routines to reduce the MGG mass matrix from the G-set to the N, M-sets. See Appendix B to the MYSTRAN User's Reference Manual
! for the derivation of the reduction equations.

! NOTE: This subr has code for sparse matrices as well as full matrices, (i.e. Bulk Data PARAM MATSPARS = 'Y' for sparse and 'N'
! for full). The code for full matrices was put in originally in order that the sparse code could be thoroughly checked. That task
! is complete and the remaining full matrix code has not been maintained since around 2005. In addition, new capability added to
! MYSTRAN since that approx time does not have full matrix code.

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE
      USE IOUNT1, ONLY                :  ERR, F04, F06, L2R, LINK2R, L2R_MSG, SC1, WRT_ERR, WRT_LOG
      USE SCONTR, ONLY                :  BLNK_SUB_NAM, FATAL_ERR, NDOFG, NDOFN, NDOFM, NTERM_MGG, NTERM_MNN, NTERM_MNM, NTERM_MMM, &
                                         NTERM_GMN, NTERM_LMN
      USE PARAMS, ONLY                :  EPSIL, MATSPARS, SPARSTOR
      USE TIMDAT, ONLY                :  TSEC
      USE SUBR_BEGEND_LEVELS, ONLY    :  REDUCE_MGG_TO_MNN_BEGEND
      USE CONSTANTS_1, ONLY           :  ONE
      USE SPARSE_MATRICES, ONLY       :  I_LMN, J_LMN, LMN, I_MGG, J_MGG, MGG, I_MNN, J_MNN, MNN, I_MNM , J_MNM , MNM ,            &
                                         I_MMN, J_MMN, MMN, I_MMM, J_MMM, MMM, I_GMN, J_GMN, GMN, I_GMNt, J_GMNt, GMNt
      USE SPARSE_MATRICES, ONLY       :  SYM_GMN, SYM_LMN, SYM_MGG, SYM_MNN, SYM_MNM, SYM_MMN, SYM_MMM
      USE FULL_MATRICES, ONLY         :  MNN_FULL, MNM_FULL, MMM_FULL, GMN_FULL, DUM1, DUM2, DUM3
      USE SCRATCH_MATRICES

      USE REDUCE_MGG_TO_MNN_USE_IFs

      IMPLICIT NONE

      CHARACTER, PARAMETER            :: CR13 = CHAR(13)   ! This causes a carriage return simulating the "+" action in a FORMAT
      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: SUBR_NAME = 'REDUCE_MGG_TO_MNN'
      CHARACTER(  1*BYTE)             :: SYM_CRS1            ! Storage format for matrix CRS1 (either 'Y' for sym storage or
!                                                              'N' for nonsymmetric storage)
      CHARACTER(  1*BYTE)             :: SYM_CRS3            ! Storage format for matrix CRS3 (either 'Y' for sym storage or
!                                                              'N' for nonsymmetric storage)

      INTEGER(LONG), INTENT(IN)       :: PART_VEC_G_NM(NDOFG)! Partitioning vector (G set into N and M sets)
      INTEGER(LONG)                   :: AROW_MAX_TERMS      ! Output from MATMULT_SFS_NTERM and input to MATMULT_SFS
      INTEGER(LONG)                   :: I,J                 ! DO loop indices
      INTEGER(LONG)                   :: ITRNSPB             ! Transpose indicator for matrix multiply routine
      INTEGER(LONG)                   :: MNN_ROW_MAX_TERMS   ! Output from subr PARTITION_SIZE (max terms in any row of matrix)
      INTEGER(LONG)                   :: MNM_ROW_MAX_TERMS   ! Output from subr PARTITION_SIZE (max terms in any row of matrix)
!xx   INTEGER(LONG)                   :: MMN_ROW_MAX_TERMS   ! Output from subr PARTITION_SIZE (max terms in any row of matrix)
      INTEGER(LONG)                   :: MMM_ROW_MAX_TERMS   ! Output from subr PARTITION_SIZE (max terms in any row of matrix)
      INTEGER(LONG)                   :: NTERM_CCS1          ! Number of terms in matrix CCS1
      INTEGER(LONG)                   :: NTERM_CRS1          ! Number of terms in matrix CRS1
      INTEGER(LONG)                   :: NTERM_CRS2          ! Number of terms in matrix CRS2
      INTEGER(LONG)                   :: NTERM_CRS3          ! Number of terms in matrix CRS3
      INTEGER(LONG)                   :: NTERM_MMN           ! Number of nonzeros in sparse matrix MMN (should = NTERM_MNM)
      INTEGER(LONG), PARAMETER        :: NUM1        = 1     ! Used in subr's that partition matrices
      INTEGER(LONG), PARAMETER        :: NUM2        = 2     ! Used in subr's that partition matrices
      INTEGER(LONG), PARAMETER        :: SUBR_BEGEND = REDUCE_MGG_TO_MNN_BEGEND

      REAL(DOUBLE)                    :: ALPHA = ONE         ! Scalar multiplier for matrix
      REAL(DOUBLE)                    :: BETA  = ONE         ! Scalar multiplier for matrix
      REAL(DOUBLE)                    :: SMALL             ! A number used in filtering out small numbers from a full matrix

      INTRINSIC                       :: DABS

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
! Partition MNN from MGG (This is MNN before reduction, or MNN(bar) )

      IF (NDOFN > 0) THEN

         CALL PARTITION_SS_NTERM ( 'MGG', NTERM_MGG, NDOFG, NDOFG, SYM_MGG, I_MGG, J_MGG,      PART_VEC_G_NM, PART_VEC_G_NM,       &
                                    NUM1, NUM1, MNN_ROW_MAX_TERMS, 'MNN', NTERM_MNN, SYM_MNN )

         CALL ALLOCATE_SPARSE_MAT ( 'MNN', NDOFN, NTERM_MNN, SUBR_NAME )

         IF (NTERM_MNN > 0) THEN
            CALL PARTITION_SS ( 'MGG', NTERM_MGG, NDOFG, NDOFG, SYM_MGG, I_MGG, J_MGG, MGG, PART_VEC_G_NM, PART_VEC_G_NM,          &
                                 NUM1, NUM1, MNN_ROW_MAX_TERMS, 'MNN', NTERM_MNN, NDOFN, SYM_MNN, I_MNN, J_MNN, MNN )
         ENDIF

      ENDIF

! Partition MNM from MGG

      IF ((NDOFN > 0) .AND. (NDOFM > 0)) THEN

         CALL PARTITION_SS_NTERM ( 'MGG', NTERM_MGG, NDOFG, NDOFG, SYM_MGG, I_MGG, J_MGG,      PART_VEC_G_NM, PART_VEC_G_NM,       &
                                    NUM1, NUM2, MNM_ROW_MAX_TERMS, 'MNM', NTERM_MNM, SYM_MNM )

         CALL ALLOCATE_SPARSE_MAT ( 'MNM', NDOFN, NTERM_MNM, SUBR_NAME )

         IF (NTERM_MNM > 0) THEN
            CALL PARTITION_SS ( 'MGG', NTERM_MGG, NDOFG, NDOFG, SYM_MGG, I_MGG, J_MGG, MGG, PART_VEC_G_NM, PART_VEC_G_NM,          &
                                 NUM1, NUM2, MNM_ROW_MAX_TERMS, 'MNM', NTERM_MNM, NDOFN, SYM_MNM, I_MNM, J_MNM, MNM )
         ENDIF

      ENDIF

! Partition MMN from MGG

      IF ((NDOFN > 0) .AND. (NDOFM > 0)) THEN

!xx      CALL PARTITION_SS_NTERM ( 'MGG', NTERM_MGG, NDOFG, NDOFG, SYM_MGG, I_MGG, J_MGG,      PART_VEC_G_NM, PART_VEC_G_NM,       &
!xx                                 NUM2, NUM1, MMN_ROW_MAX_TERMS, 'MMN', NTERM_MMN, SYM_MMN )

!xx      IF (NTERM_MMN /= NTERM_MNM) THEN
!xx         FATAL_ERR = FATAL_ERR + 1
!xx         WRITE(ERR,936) SUBR_NAME, NTERM_MMN, NTERM_MNM
!xx         WRITE(F06,936) SUBR_NAME, NTERM_MMN, NTERM_MNM
!xx         CALL OUTA_HERE ( 'Y' )
!xx      ENDIF

!xx      CALL ALLOCATE_SPARSE_MAT ( 'MMN', NDOFN, NTERM_MMN, SUBR_NAME )

!xx      IF (NTERM_MMN > 0) THEN
!xx         CALL PARTITION_SS ( 'MGG', NTERM_MGG, NDOFG, NDOFG, SYM_MGG, I_MGG, J_MGG, MGG, PART_VEC_G_NM, PART_VEC_G_NM,          &
!xx                              NUM2, NUM1, MMN_ROW_MAX_TERMS, 'MMN', NTERM_MMN, NDOFN, SYM_MMN, I_MMN, J_MMN, MMN )
!xx      ENDIF

         CALL ALLOCATE_SPARSE_MAT ( 'MMN', NDOFM, NTERM_MNM, SUBR_NAME )

         NTERM_MMN = NTERM_MNM
         IF (NTERM_MMN > 0) THEN
            CALL MATTRNSP_SS ( NDOFN, NDOFM, NTERM_MNM, 'MNM', I_MNM, J_MNM, MNM, 'MMN', I_MMN, J_MMN, MMN )

         ENDIF

      ENDIF

! Partition MMM from MGG

      IF (NDOFM > 0) THEN

         CALL PARTITION_SS_NTERM ( 'MGG', NTERM_MGG, NDOFG, NDOFG, SYM_MGG, I_MGG, J_MGG,      PART_VEC_G_NM, PART_VEC_G_NM,       &
                                    NUM2, NUM2, MMM_ROW_MAX_TERMS, 'MMM', NTERM_MMM, SYM_MMM )

         CALL ALLOCATE_SPARSE_MAT ( 'MMM', NDOFM, NTERM_MMM, SUBR_NAME )

         IF (NTERM_MMM > 0) THEN
            CALL PARTITION_SS ( 'MGG', NTERM_MGG, NDOFG, NDOFG, SYM_MGG, I_MGG, J_MGG, MGG, PART_VEC_G_NM, PART_VEC_G_NM,          &
                                 NUM2, NUM2, MMM_ROW_MAX_TERMS, 'MMM', NTERM_MMM, NDOFM, SYM_MMM, I_MMM, J_MMM, MMM )
         ENDIF

      ENDIF

! ----------------------------------------------------------------------------------------------------------------------------------
! Reduce MGG to MNN = MNN(bar) + MNM*GMN + (MNM*GMN)' + GMN'*MMM*GMN.
! If PARAM MATSPARS = 'Y', then we use sparse matrix operations (multiply/add/transpose). If not, use full matrix operations

      IF (MATSPARS == 'Y') THEN

         CALL ALLOCATE_SPARSE_MAT ( 'GMNt', NDOFN, NTERM_GMN, SUBR_NAME )
         CALL MATTRNSP_SS ( NDOFM, NDOFN, NTERM_GMN, 'GMN', I_GMN, J_GMN, GMN, 'GMNt', I_GMNt, J_GMNt, GMNt )

                                                           ! CCS1 will be sparse CCS format version of sparse CRS matrix GMN
         CALL ALLOCATE_SCR_CCS_MAT ( 'CCS1', NDOFN, NTERM_GMN, SUBR_NAME )
         CALL SPARSE_CRS_SPARSE_CCS ( NDOFM, NDOFN, NTERM_GMN, 'GMN', I_GMN, J_GMN, GMN, 'CCS1', J_CCS1, I_CCS1, CCS1, 'Y' )

         IF (NTERM_MNM > 0) THEN                           ! Part I of reduced MNN: calc MNM*GMN & add it & transpose to orig MNN

                                                           ! I-1, sparse multiply to get CRS1 = MNM*GMN. Use CCS1 for GMN CCS
            CALL MATMULT_SSS_NTERM ( 'MNM' , NDOFN, NTERM_MNM , SYM_MNM, I_MNM , J_MNM ,                                           &
                                     'GMN' , NDOFN, NTERM_GMN , SYM_GMN, J_CCS1, I_CCS1, AROW_MAX_TERMS,                           &
                                     'CRS1' ,       NTERM_CRS1 )

            CALL ALLOCATE_SCR_CRS_MAT ( 'CRS1', NDOFN, NTERM_CRS1, SUBR_NAME )

            CALL MATMULT_SSS ( 'MNM' , NDOFN, NTERM_MNM , SYM_MNM, I_MNM , J_MNM , MNM ,                                           &
                               'GMN' , NDOFN, NTERM_GMN , SYM_GMN, J_CCS1, I_CCS1, CCS1, AROW_MAX_TERMS,                           &
                               'CRS1', ONE  , NTERM_CRS1,          I_CRS1, J_CRS1, CRS1 )

            NTERM_CRS2 = NTERM_CRS1                        ! I-2, allocate memory to array CRS2 which will hold transpose of CRS1
            CALL ALLOCATE_SCR_CRS_MAT ( 'CRS2', NDOFN, NTERM_CRS2, SUBR_NAME )

                                                           ! I-3, transpose CRS1 to get CRS2 = (MNM*GMN)t
            CALL MATTRNSP_SS ( NDOFN, NDOFN, NTERM_CRS1, 'CRS1', I_CRS1, J_CRS1, CRS1, 'CRS2', I_CRS2, J_CRS2, CRS2 )

                                                           ! I-4, sparse add to get CRS3 = CRS1 + CRS2 = (MNM*GMN) + (MNM*GMN)t
            CALL MATADD_SSS_NTERM (NDOFN,'MNM*GMN', NTERM_CRS1, I_CRS1, J_CRS1, 'N', '(MNM*GMN)t', NTERM_CRS2, I_CRS2, J_CRS2, 'N',&
                                         'CRS3', NTERM_CRS3)
            CALL ALLOCATE_SCR_CRS_MAT ( 'CRS3', NDOFN, NTERM_CRS3, SUBR_NAME )
            CALL MATADD_SSS ( NDOFN, 'MNM*GMN', NTERM_CRS1, I_CRS1, J_CRS1, CRS1, ONE, '(MNM*GMN)t', NTERM_CRS2, I_CRS2, J_CRS2,   &
                              CRS2, ONE, 'CRS3', NTERM_CRS3, I_CRS3, J_CRS3, CRS3 )

            CALL DEALLOCATE_SCR_MAT ( 'CRS1' )             ! I-5, deallocate CRS1, CRS2
            CALL DEALLOCATE_SCR_MAT ( 'CRS2' )             ! I-6, deallocate CRS2 which was (MNM*GMN)t

                                                           ! I-7, CRS3 = (MNM*GMN) + (MNM*GMN)t has all nonzero terms in it.
            IF      (SPARSTOR == 'SYM   ') THEN            !      If SPARSTOR == 'SYM   ', rewrite CRS3 as sym in CRS1

               CALL SPARSE_CRS_TERM_COUNT ( NDOFN, NTERM_CRS3, '(MNM*GMN) + (MNM*GMN)t', I_CRS3, J_CRS3, NTERM_CRS1 )
               CALL ALLOCATE_SCR_CRS_MAT ( 'CRS1', NDOFN, NTERM_CRS1, SUBR_NAME )
               CALL CRS_NONSYM_TO_CRS_SYM ( 'CRS3 = (MNM*GMN) + (MNM*GMN)t all nonzeros', NDOFN, NTERM_CRS3, I_CRS3, J_CRS3, CRS3,&
                                            'CRS1 = (MNM*GMN) + (MNM*GMN)t stored sym'  ,        NTERM_CRS1, I_CRS1, J_CRS1, CRS1 )
               SYM_CRS1 = 'Y'

            ELSE IF (SPARSTOR == 'NONSYM') THEN            !      If SPARSTOR == 'NONSYM', rewrite CRS3 in CRS1 with NTERM_CRS3

               NTERM_CRS1 = NTERM_CRS3
               CALL ALLOCATE_SCR_CRS_MAT ( 'CRS1', NDOFN, NTERM_CRS1, SUBR_NAME )
               DO I=1,NDOFN+1
                  I_CRS1(I) = I_CRS3(I)
               ENDDO
               DO I=1,NTERM_CRS1
                  J_CRS1(I) = J_CRS3(I)
                    CRS1(I) =   CRS3(I)
               ENDDO
               SYM_CRS1 = 'N'

            ELSE                                           !      Error - incorrect SPARSTOR

               WRITE(ERR,932) SUBR_NAME, SPARSTOR
               WRITE(F06,932) SUBR_NAME, SPARSTOR
               FATAL_ERR = FATAL_ERR + 1
               CALL OUTA_HERE ( 'Y' )

            ENDIF

            CALL DEALLOCATE_SCR_MAT ( 'CRS3' )             ! I-8, deallocate CRS3

                                                           ! I-9, sparse add to get CRS3 = MNN-bar + CRS1 = (MNM*GMN) + (MNM*GMN)t
            CALL MATADD_SSS_NTERM ( NDOFN, 'MNN-bar', NTERM_MNN, I_MNN, J_MNN, SYM_MNN, 'MNM*GMN + (MNM*GMN)t',                    &
                                    NTERM_CRS1, I_CRS1, J_CRS1, SYM_CRS1, 'CRS3', NTERM_CRS3 )
            CALL ALLOCATE_SCR_CRS_MAT ( 'CRS3', NDOFN, NTERM_CRS3, SUBR_NAME )
            CALL MATADD_SSS ( NDOFN, 'MNN-bar', NTERM_MNN, I_MNN, J_MNN, MNN, ONE, 'MNM*GMN + (MNM*GMN)t', NTERM_CRS1,             &
                              I_CRS1, J_CRS1, CRS1, ONE, 'CRS1', NTERM_CRS3, I_CRS3, J_CRS3, CRS3 )

            CALL DEALLOCATE_SCR_MAT ( 'CRS1' )             ! I-10, deallocate CRS1 and CRS3

            NTERM_MNN = NTERM_CRS3                         ! I-11, reallocate MNN to be size of CRS1
            WRITE(SC1, * ) '    Reallocate MNN'
      !xx   WRITE(SC1, * )                                 ! Advance 1 line for screen messages
            WRITE(SC1,12345,ADVANCE='NO') '       Deallocate MNN', CR13
            CALL DEALLOCATE_SPARSE_MAT ( 'MNN' )
            WRITE(SC1,12345,ADVANCE='NO') '       Allocate   MNN', CR13
            CALL ALLOCATE_SPARSE_MAT ( 'MNN', NDOFN, NTERM_MNN, SUBR_NAME )
                                                           ! I-12, set MNN = CRS1
            DO I=1,NDOFN+1
               I_MNN(I) = I_CRS3(I)
            ENDDO
            DO J=1,NTERM_MNN
               J_MNN(J) = J_CRS3(J)
                 MNN(J) =   CRS3(J)
            ENDDO

            CALL DEALLOCATE_SCR_MAT ( 'CRS3' )             ! I-13, deallocate CRS3
                                                           ! At this point, CRS1, CRS2, CRS3 are deallocated, CCS1 is being used
         ENDIF

         IF (NTERM_MMM > 0) THEN                           ! Part II of reduced MNN: calc GMN(t)*MMM*GMN and add to MNN

                                                           ! II-1 sparse multiply to get CRS1 = MMM*GMN using CCS1 for GMN CCS
            CALL MATMULT_SSS_NTERM ( 'MMM' , NDOFM, NTERM_MMM , SYM_MMM, I_MMM , J_MMM ,                                           &
                                     'GMN' , NDOFN, NTERM_GMN , SYM_GMN, J_CCS1, I_CCS1, AROW_MAX_TERMS,                           &
                                     'CRS1' ,       NTERM_CRS1 )
            CALL ALLOCATE_SCR_CRS_MAT ( 'CRS1', NDOFM, NTERM_CRS1, SUBR_NAME )
            CALL MATMULT_SSS ( 'MMM' , NDOFM, NTERM_MMM , SYM_MMM, I_MMM , J_MMM , MMM ,                                           &
                               'GMN' , NDOFN, NTERM_GMN , SYM_GMN, J_CCS1, I_CCS1, CCS1,  AROW_MAX_TERMS,                          &
                               'CRS1', ONE  , NTERM_CRS1,          I_CRS1, J_CRS1, CRS1 )

            IF (NTERM_MMN > 0) THEN
               CALL MATADD_SSS_NTERM (NDOFM, 'MMM*GMN', NTERM_CRS1, I_CRS1, J_CRS1, 'N', 'MMN', NTERM_MMN, I_MMN, J_MMN, SYM_MMN,  &
                                             'LMN', NTERM_LMN)

               CALL ALLOCATE_SPARSE_MAT ( 'LMN', NDOFM, NTERM_LMN, SUBR_NAME )

               CALL MATADD_SSS ( NDOFM, 'MMM*GM', NTERM_CRS1, I_CRS1, J_CRS1, CRS1, ONE, 'MMN', NTERM_MMN, I_MMN, J_MMN, MMN,      &
                                 ONE, 'LMN', NTERM_LMN, I_LMN, J_LMN, LMN )
            ELSE
               NTERM_LMN = NTERM_CRS1
               CALL ALLOCATE_SPARSE_MAT ( 'LMN', NDOFM, NTERM_LMN, SUBR_NAME )
               DO I=1,NDOFM+1
                  I_LMN(I) = I_CRS1(I)
               ENDDO
               DO I=1,NTERM_LMN
                  J_LMN(I) = J_CRS1(I)
                  LMN(I) =   CRS1(I)
               ENDDO
            ENDIF

            CALL DEALLOCATE_SCR_MAT ( 'CCS1' )             ! II-2 , deallocate CCS1 which was CCS version of GMN

            NTERM_CCS1 = NTERM_CRS1                        ! II-3 , allocate CCS1 to be same as CRS1 but in CCS format
            CALL ALLOCATE_SCR_CCS_MAT ( 'CCS1', NDOFN, NTERM_CCS1, SUBR_NAME )
            CALL SPARSE_CRS_SPARSE_CCS ( NDOFM, NDOFN, NTERM_CRS1, 'CRS1', I_CRS1, J_CRS1, CRS1, 'CCS1', J_CCS1, I_CCS1, CCS1, 'Y' )

            CALL DEALLOCATE_SCR_MAT ( 'CRS1' )             ! II-4 , deallocate CRS1
                                                           ! II-5 , sparse multiply to get CRS1 = GMNt*CCS1 with CCS1 = MMM*GMN
!                                                            (note: use SYM_GMN for sym indicator for CCS1)
            CALL MATMULT_SSS_NTERM ( 'GMNt', NDOFN, NTERM_GMN , SYM_GMN, I_GMNt, J_GMNt,                                           &
                                     'CCS1', NDOFN, NTERM_CCS1, SYM_GMN, J_CCS1, I_CCS1, AROW_MAX_TERMS,                           &
                                     'CRS1 ',       NTERM_CRS1 )

            CALL ALLOCATE_SCR_CRS_MAT ( 'CRS1', NDOFN, NTERM_CRS1, SUBR_NAME )

            CALL MATMULT_SSS ( 'GMNt', NDOFN, NTERM_GMN , SYM_GMN, I_GMNt, J_GMNt, GMNt,                                           &
                               'CCS1', NDOFN, NTERM_CCS1, SYM_GMN, J_CCS1, I_CCS1, CCS1, AROW_MAX_TERMS,                           &
                               'CRS1', ONE  , NTERM_CRS1,          I_CRS1, J_CRS1, CRS1 )

            CALL DEALLOCATE_SCR_MAT ( 'CCS1' )             ! II-6 , deallocate CCS1

                                                           ! II-7 , CRS1 = GMNt*MMM*GMN has all nonzero terms in it.
            IF      (SPARSTOR == 'SYM   ') THEN            !      If SPARSTOR == 'SYM   ', rewrite CRS1 as sym in CRS3

               CALL SPARSE_CRS_TERM_COUNT ( NDOFN, NTERM_CRS1, 'GMNt*MMM*GMN all nonzeros', I_CRS1, J_CRS1, NTERM_CRS3 )
               CALL ALLOCATE_SCR_CRS_MAT ( 'CRS3', NDOFN, NTERM_CRS3, SUBR_NAME )
               CALL CRS_NONSYM_TO_CRS_SYM ( 'CRS1 = GMNt*MMM*GMN all nonzeros', NDOFN, NTERM_CRS1, I_CRS1, J_CRS1, CRS1,           &
                                            'CRS3 = GMNt*MMM*GMN stored sym'  ,        NTERM_CRS3, I_CRS3, J_CRS3, CRS3 )
               SYM_CRS3 = 'Y'

            ELSE IF (SPARSTOR == 'NONSYM') THEN            !      If SPARSTOR == 'NONSYM', rewrite CRS3 in CRS1 with NTERM_CRS3

               NTERM_CRS3 = NTERM_CRS1
               CALL ALLOCATE_SCR_CRS_MAT ( 'CRS3', NDOFN, NTERM_CRS3, SUBR_NAME )
               DO I=1,NDOFN+1
                  I_CRS3(I) = I_CRS1(I)
               ENDDO
               DO I=1,NTERM_CRS3
                  J_CRS3(I) = J_CRS1(I)
                    CRS3(I) =   CRS1(I)
               ENDDO
               SYM_CRS3 = 'N'

            ELSE                                           !      Error - incorrect SPARSTOR

               WRITE(ERR,932) SUBR_NAME, SPARSTOR
               WRITE(F06,932) SUBR_NAME, SPARSTOR
               FATAL_ERR = FATAL_ERR + 1
               CALL OUTA_HERE ( 'Y' )

            ENDIF
                                                           ! II-8 , sparse add to get CRS2 = MNN + CRS3 = MNN + GMNt*MMM*GMN
            CALL MATADD_SSS_NTERM ( NDOFN, 'MNN-bar + MNM*GMN + (MNM*GMN)t', NTERM_MNN, I_MNN, J_MNN, SYM_MNN, 'GMNt*MMM*GMN',     &
                                    NTERM_CRS3, I_CRS3, J_CRS3, SYM_CRS3, 'CRS2', NTERM_CRS2 )
            CALL ALLOCATE_SCR_CRS_MAT ( 'CRS2', NDOFN, NTERM_CRS2, SUBR_NAME )
            CALL MATADD_SSS ( NDOFN, 'MNN-bar + MNM*GMN + (MNM*GMN)t' , NTERM_MNN , I_MNN , J_MNN , MNN, ONE, 'GMNt*MMM*GMN',      &
                              NTERM_CRS3, I_CRS3, J_CRS3, CRS3, ONE, 'CRS2', NTERM_CRS2, I_CRS2, J_CRS2, CRS2 )

            CALL DEALLOCATE_SCR_MAT ( 'CRS1' )             ! II-9 , deallocate CRS1 and CRS3
            CALL DEALLOCATE_SCR_MAT ( 'CRS3' )             ! II-10, deallocate CRS3

            NTERM_MNN = NTERM_CRS2                         ! II-11, reallocate MNN to be size of CRS2
            WRITE(SC1, * ) '    Reallocate MNN'
      !xx   WRITE(SC1, * )                                 ! Advance 1 line for screen messages
            WRITE(SC1,12345,ADVANCE='NO') '       Deallocate MNN', CR13
            CALL DEALLOCATE_SPARSE_MAT ( 'MNN' )
            WRITE(SC1,12345,ADVANCE='NO') '       Allocate   MNN', CR13
            CALL ALLOCATE_SPARSE_MAT ( 'MNN', NDOFN, NTERM_MNN, SUBR_NAME )

            DO I=1,NDOFN+1                                 ! II-12, set reduced MNN = CRS2 until we see if MNM is null, below
               I_MNN(I) = I_CRS2(I)
            ENDDO
            DO I=1,NTERM_MNN
               J_MNN(I) = J_CRS2(I)
                 MNN(I) =   CRS2(I)
            ENDDO

            CALL DEALLOCATE_SCR_MAT ( 'CRS2' )             ! II-13, Deallocate CRS2

         ELSE                                              ! MMM is null

            CALL DEALLOCATE_SCR_MAT ( 'CCS1')

            IF (NTERM_MMN > 0) THEN                        ! Set LMN - MMN if MMN nonzero, else LMN is null
               NTERM_LMN = NTERM_MMN
               CALL ALLOCATE_SPARSE_MAT ( 'LMN', NDOFM, NTERM_LMN, SUBR_NAME )
               DO I=1,NDOFM+1
                  I_LMN(I) = I_MMN(I)
               ENDDO
               DO I=1,NTERM_LMN
                  J_LMN(I) = J_MMN(I)
                  LMN(I) =   MMN(I)
               ENDDO
            ELSE
               NTERM_LMN = 0
            ENDIF

         ENDIF

         IF (NTERM_LMN > 0) THEN
            CALL WRITE_MATRIX_1 ( LINK2R, L2R, 'Y', 'KEEP', L2R_MSG, 'LMN', NTERM_LMN, NDOFM, I_LMN, J_LMN, LMN )
         ENDIF

         WRITE(SC1, * ) '     DEALLOCATE SOME ARRAYS'
   !xx   WRITE(SC1, * )                                    ! Advance 1 line for screen messages
         WRITE(SC1,12345,ADVANCE='NO') '       Deallocate GMNt', CR13
         CALL DEALLOCATE_SPARSE_MAT ( 'GMNt' )
         WRITE(SC1,12345,ADVANCE='NO') '       Deallocate LMN ', CR13
         CALL DEALLOCATE_SPARSE_MAT ( 'LMN' )

! ----------------------------------------------------------------------------------------------------------------------------------
      ELSE IF (MATSPARS == 'N') THEN

         CALL ALLOCATE_FULL_MAT ( 'MNN_FULL', NDOFN, NDOFN, SUBR_NAME )

         IF (NTERM_MNN > 0) THEN
            CALL SPARSE_CRS_TO_FULL ( 'MNN', NTERM_MNN, NDOFN, NDOFN, SYM_MNN, I_MNN, J_MNN,MNN, MNN_FULL )
         ENDIF

         IF (NTERM_MNM > 0) THEN                           ! Part 1: calc MNM*GMN and add it & it's transpose to MNN_FULL

            CALL ALLOCATE_FULL_MAT ( 'MNM_FULL', NDOFN, NDOFM, SUBR_NAME )
            CALL SPARSE_CRS_TO_FULL ( 'MNM', NTERM_MNM, NDOFN, NDOFM, SYM_MNM, I_MNM, J_MNM, MNM, MNM_FULL )

            CALL ALLOCATE_FULL_MAT ( 'GMN_FULL', NDOFM, NDOFN, SUBR_NAME )
            CALL SPARSE_CRS_TO_FULL ( 'GMN', NTERM_GMN, NDOFM, NDOFN, SYM_GMN, I_GMN, J_GMN, GMN, GMN_FULL )

            CALL ALLOCATE_FULL_MAT ( 'DUM1', NDOFN, NDOFN, SUBR_NAME )

            CALL MATMULT_FFF (  MNM_FULL, GMN_FULL, NDOFN, NDOFM, NDOFN, DUM1 )

            CALL DEALLOCATE_FULL_MAT ( 'MNM_FULL' )
            CALL DEALLOCATE_FULL_MAT ( 'GMN_FULL' )
            CALL ALLOCATE_FULL_MAT ( 'DUM2', NDOFN, NDOFN, SUBR_NAME )

            ITRNSPB = 0                                    ! Calc MNN-bar + MNM*GMN = MNN + DUM1 and put into DUM1
            CALL MATADD_FFF ( MNN_FULL, DUM1, NDOFN, NDOFN, ALPHA, BETA, ITRNSPB, DUM2 )
            ITRNSPB = 1                                    ! Calc MNN-bar + MNM*GMN + (MNM*GMN)' = DUM2+DUM1' and put into MNN_FULL
            CALL MATADD_FFF ( DUM2    , DUM1, NDOFN, NDOFN, ALPHA, BETA, ITRNSPB, MNN_FULL )

            CALL DEALLOCATE_FULL_MAT ( 'DUM1' )
            CALL DEALLOCATE_FULL_MAT ( 'DUM2' )

         ENDIF

         IF (NTERM_MMM > 0) THEN                           ! Part 2: calc GMN(t)*MMM*GMN and add to MNN_FULL

            CALL ALLOCATE_FULL_MAT ( 'MMM_FULL', NDOFM, NDOFM, SUBR_NAME )
            CALL SPARSE_CRS_TO_FULL ( 'MMM', NTERM_MMM, NDOFM, NDOFM, SYM_MMM, I_MMM, J_MMM, MMM, MMM_FULL )

            CALL ALLOCATE_FULL_MAT ( 'GMN_FULL', NDOFM, NDOFN, SUBR_NAME )
            CALL SPARSE_CRS_TO_FULL ( 'GMN', NTERM_GMN, NDOFM, NDOFN, SYM_GMN, I_GMN, J_GMN, GMN, GMN_FULL )

            CALL ALLOCATE_FULL_MAT ( 'DUM2', NDOFM, NDOFN, SUBR_NAME )

            CALL MATMULT_FFF ( MMM_FULL, GMN_FULL, NDOFM, NDOFM, NDOFN, DUM2 )

            CALL DEALLOCATE_FULL_MAT ( 'MMM_FULL' )

            CALL ALLOCATE_FULL_MAT ( 'DUM1', NDOFN, NDOFN, SUBR_NAME )

            CALL MATMULT_FFF_T (GMN_FULL, DUM2, NDOFM, NDOFN, NDOFN, DUM1 )

            CALL DEALLOCATE_FULL_MAT ( 'DUM2' )

            CALL DEALLOCATE_FULL_MAT ( 'GMN_FULL' )

            CALL ALLOCATE_FULL_MAT ( 'DUM2', NDOFN, NDOFN, SUBR_NAME )

            ITRNSPB = 0
            CALL MATADD_FFF ( MNN_FULL, DUM1, NDOFN, NDOFN, ALPHA, BETA, ITRNSPB, DUM2 )
            DO I=1,NDOFN
               DO J=1,NDOFN
                  MNN_FULL(I,J) = DUM2(I,J)
               ENDDO
            ENDDO

            CALL DEALLOCATE_FULL_MAT ( 'DUM1' )
            CALL DEALLOCATE_FULL_MAT ( 'DUM2' )

         ENDIF

         CALL CNT_NONZ_IN_FULL_MAT ( 'MNN_FULL  ', MNN_FULL, NDOFN, NDOFN, SYM_MNN, NTERM_MNN, SMALL )

         WRITE(SC1, * ) '    Reallocate MNN'
   !xx   WRITE(SC1, * )                                    ! Advance 1 line for screen messages
         WRITE(SC1,12345,ADVANCE='NO') '       Deallocate MNN', CR13
         CALL DEALLOCATE_SPARSE_MAT ( 'MNN' )
         WRITE(SC1,12345,ADVANCE='NO') '       Allocate   MNN', CR13
         CALL ALLOCATE_SPARSE_MAT ( 'MNN', NDOFN, NTERM_MNN, SUBR_NAME )

         IF (NTERM_MNN > 0) THEN                            ! Create new sparse arrays from MNN_FULL
!xx         CALL FULL_TO_SPARSE_CRS ( 'MNN_FULL  ', NDOFN, NDOFN, MNN_FULL, NTERM_MNN, SYM_MNN, I_MNN, J_MNN, MNN )
            CALL DEALLOCATE_FULL_MAT ( 'MNN_FULL' )
         ENDIF

      ELSE

         WRITE(ERR,911) SUBR_NAME,MATSPARS
         WRITE(F06,911) SUBR_NAME,MATSPARS
         FATAL_ERR = FATAL_ERR + 1
         CALL OUTA_HERE ( 'Y' )

      ENDIF

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

! **********************************************************************************************************************************
  911 FORMAT(' *ERROR   911: PROGRAMMING ERROR IN SUBROUTINE ',A                                                                   &
                    ,/,14X,' PARAMETER MATSPARS MUST BE EITHER ','Y',' OR ','N',' BUT VALUE IS ',A)

  932 FORMAT(' *ERROR   932: PROGRAMMING ERROR IN SUBROUTINE ',A                                                                   &
                    ,/,14X,' PARAMETER SPARSTOR MUST BE EITHER "SYM" OR "NONSYM" BUT VALUE IS ',A)

  936 FORMAT(' *ERROR   936: PROGRAMMING ERROR IN SUBROUTINE ',A                                                                   &
                    ,/,14X,' THE NUMBER OF NONZERO TERMS IN SPARSE MATRIX MMN = ',I12,' IS NOT EQUAL TO THOSE IN MATRIX MNM = ',I12)

12345 FORMAT(A,10X,A)

! **********************************************************************************************************************************

      END SUBROUTINE REDUCE_MGG_TO_MNN