C$Procedure XPSGIP ( Transpose a matrix, general dimension, in place )

      SUBROUTINE XPSGIP ( NROW, NCOL, MATRIX )

C$ Abstract
C
C     Transpose a matrix of arbitrary size and shape in place.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     MATRIX
C
C$ Declarations

      INTEGER            NROW
      INTEGER            NCOL
      DOUBLE PRECISION   MATRIX ( 0 : * )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     NROW       I   Number of rows of input matrix.
C     NCOL       I   Number of columns of input matrix.
C     MATRIX    I-O  Matrix to be transposed/transposed matrix.
C
C$ Detailed_Input
C
C     MATRIX     Matrix to be transposed.
C
C     NROW       Number of rows of input matrix MATRIX.
C
C     NCOL       Number of columns of input matrix MATRIX.
C
C$ Detailed_Output
C
C     MATRIX     Transposed matrix:  element (i,j) of the input
C                matrix is element (j,i) of the output matrix.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error Free.
C
C     1) If either NROW or NCOL is less than or equal to zero, no action
C        is taken. The routine simply returns.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine replaces the input matrix MATRIX with its transpose.
C
C     NOTE:  The matrix MATRIX is declared one-dimensional for
C            computational purposes only.  The calling program may
C            declare it as MATRIX(NROW,NCOL) or MATRIX(NCOL,NROW).
C
C            This routine assumes that the elements of the matrix to be
C            transformed are stored in contiguous memory locations as
C            shown here.  On output these elements will be rearranged
C            in consecutive memory locations as shown.
C
C               MATRIX on input      MATRIX on output
C
C                m_11                m_11
C                m_21                m_12
C                m_31                m_13
C                 .                   .
C                 .                   .
C                 .                  m_1ncol
C                m_nrow1             m_21
C                m_12                m_22
C                m_22                m_23
C                m_32                 .
C                 .                   .
C                 .                  m_2ncol
C                 .                   .
C                m_nrow2
C                 .                   .
C
C                 .                   .
C
C                 .                   .
C                m_1ncol
C                m_2ncol             m_nrow1
C                m_3ncol             m_nrow2
C                 .                  m_nrow3
C                 .                   .
C                 .                   .
C                m_nrowncol          m_nrowncol
C
C
C     For those familiar with permutations, this algorithm relies
C     upon the fact that the transposition of a matrix, which has
C     been stored as a 1-dimensional array, is simply the action of a
C     permutation applied to that array.  Since any permutation
C     can be decomposed as a product of disjoint cycles, it is
C     possible to transpose the matrix with only one additional
C     storage register.  However, once a cycle has been computed
C     it is necessary to find the next entry in the array that
C     has not been moved by the permutation.  For this reason the
C     algorithm is slower than would be necessary if the numbers
C     of rows and columns were known in advance.
C
C$ Examples
C
C     This routine is provided for situation where it is convenient to
C     transpose a general two-dimensional matrix
C     in place rather than store the result in a
C     separate array.  Note that the call
C
C        CALL XPOSEG ( MATRIX, NROW, NCOL, MATRIX )
C
C     is not permitted by the ANSI Fortran 77 standard; this routine
C     can be called instead to achieve the same result.
C
C$ Restrictions
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C     W.L. Taber      (JPL)
C
C$ Literature_References
C
C     None.
C
C$ Version
C
C-    SPICELIB Version 1.0.1, 19-SEP-2006 (EDW)
C
C        Initial version date unknown. Version data entry
C        added this date.
C

C
C-&

C$ Index_Entries
C
C     transpose a matrix general
C
C-&

C
C     Local Variables
C
      DOUBLE PRECISION      SOURCE
      DOUBLE PRECISION      TEMP

      INTEGER               DEST
      INTEGER               K
      INTEGER               M
      INTEGER               MOVED
      INTEGER               N
      INTEGER               NMOVES
      INTEGER               R
      INTEGER               START

C
C     Take care of dumb cases first.
C
      IF ( ( NROW .LE. 0 ) .OR. ( NCOL .LE. 0 ) ) THEN
         RETURN
      END IF

C
C     Use the abbreviations N and M for NROW and NCOL.
C
      N      = NROW
      M      = NCOL

C
C     Set up the upper bound for the number of objects to be moved and
C     initialize the counters.
C
      NMOVES = N*M - 2
      MOVED  = 0
      START  = 1

C
C     Until MOVED is equal to NMOVES, there is some matrix element that
C     has not been moved to its proper location in the transpose matrix.
C
      DO WHILE ( MOVED .LT. NMOVES )

         SOURCE  =  MATRIX( START )
         K       =  START / N
         R       =  START - N*K
         DEST    =  R*M   + K

C
C        Perform this cycle of the permutation.  We will be done when
C        the destination of the next element is equal to the starting
C        position of the first element to be moved in this cycle.
C
         DO WHILE ( DEST .NE. START )

            TEMP           = MATRIX( DEST )
            MATRIX( DEST ) = SOURCE
            SOURCE         = TEMP

            MOVED          = MOVED + 1
            K              = DEST  / N
            R              = DEST  - K*N
            DEST           = M*R   + K

         END DO

         MATRIX( DEST ) = SOURCE
         DEST           = 0
         MOVED          = MOVED + 1

C
C        Find the next element of the matrix that has not already been
C        moved by the transposition operation.
C
         IF ( MOVED .LT. NMOVES ) THEN

            DO WHILE ( DEST .NE. START )

               START = START + 1
               K     = START / N
               R     = START - K*N
               DEST  = R*M   + K

               DO WHILE ( DEST .GT. START )

                  K     = DEST / N
                  R     = DEST - K*N
                  DEST  = M*R  + K

               END DO

            END DO

         END IF

      END DO

      RETURN
      END


C
C**************************  RELAX  ************************************
C
C  apply nonlinear relaxation parameter OMEGA to update current
C  pressure head values
C
C***********************************************************************
C
      SUBROUTINE RELAX(N,OMEGA,PNEW,POLD)
C
      IMPLICIT  NONE
      INTEGER   K
      INTEGER   N
      REAL*8    OMEGA1
      REAL*8    OMEGA
      REAL*8    PNEW(*),POLD(*)
C
      OMEGA1=1.0D0 - OMEGA
      DO K=1,N
         PNEW(K)=OMEGA*PNEW(K) + OMEGA1*POLD(K)
      END DO
C
      RETURN
      END


      SUBROUTINE interp(xnew, xold, scalxc, nsnew, nsold)
      USE vmec_main, ONLY: dp, rprec, mnsize
      USE vmec_params, ONLY: ntmax
      USE vmec_persistent, ONLY: ixm
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER nsnew, nsold
      REAL(rprec), DIMENSION(nsnew,mnsize,3*ntmax),
     1  INTENT(out) :: xnew
      REAL(rprec), DIMENSION(nsnew,mnsize,3*ntmax),
     1  INTENT(in) :: scalxc
      REAL(rprec), DIMENSION(nsold,mnsize,3*ntmax) :: xold
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      REAL(rprec), PARAMETER :: p5 = 0.5_dp, two = 2,
     1   zero = 0, one = 1
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: ntype, js, js1, js2
      REAL(rprec) :: hsold, sj, s1, xint
C-----------------------------------------------

      IF (nsold .le. 0) RETURN
      hsold = one/(nsold - 1)
!
!       INTERPOLATE R,Z AND LAMBDA ON FULL GRID
!       (EXTRAPOLATE M=1 MODES,OVER SQRT(S), TO ORIGIN)
!       ON ENTRY, XOLD = X(COARSE MESH) * SCALXC(COARSE MESH)
!       ON EXIT,  XNEW = X(NEW MESH)   [ NOT SCALED BY 1/SQRTS ]
!

      DO ntype = 1, 3*ntmax

         WHERE (MOD(ixm(:mnsize),2) .eq. 1) xold(1,:,ntype) =
     1       two*xold(2,:,ntype) - xold(3,:,ntype)

         DO js = 1, nsnew
            sj = REAL(js - 1,rprec)/(nsnew - 1)
            js1 = 1 + ((js - 1)*(nsold - 1))/(nsnew - 1)
            js2 = MIN(js1 + 1,nsold)
            s1 = (js1 - 1)*hsold
            xint = (sj - s1)/hsold
            xint = MIN(one,xint)
            xint = MAX(zero,xint)
            xnew(js,:,ntype) = ((one - xint)*xold(js1,:,ntype)+xint*
     1         xold(js2,:,ntype))/scalxc(js,:,1)
         END DO

!        Zero M=1 modes at origin
         WHERE (MOD(ixm(:mnsize),2) .eq. 1) xnew(1,:,ntype) = 0

      END DO

      END SUBROUTINE interp


       program loop

       integer :: i,j
       integer :: iter,count_rate, count_max,count
       integer :: t_start,t_final

       integer, parameter :: n=1024,m=1024
       double precision, allocatable   :: a(:,:),b(:,:),c(:,:)

       allocate(a(n,m)); allocate(b(n,m)); allocate(c(n,m))

!generate random vectors
       CALL RANDOM_NUMBER(b)
       CALL RANDOM_NUMBER(c)

       call system_clock(count_max=count_max, count_rate=count_rate)

       call system_clock(t_start)

!parallelise the following loop
       do i=1,n
         do j=1,m
            a(i,j) = b(i,j) + c(i,j)
         enddo
       enddo

       call system_clock(t_final)

       time_s = real(t_final - t_start)/real(count_rate)

       print*, '--Time it takes (s)', time_s
        write(*,*)'--it is done: sum', sum(a)
       end


      real*8 function sqdist(x1,y1,z1,x2,y2,z2,ind,MAXROT,rotmat)
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
C                                                                      %
C Copyright (C) 1996, The Board of Trustees of the Leland Stanford     %
C Junior University.  All rights reserved.                             %
C                                                                      %
C The programs in GSLIB are distributed in the hope that they will be  %
C useful, but WITHOUT ANY WARRANTY.  No author or distributor accepts  %
C responsibility to anyone for the consequences of using them or for   %
C whether they serve any particular purpose or work at all, unless he  %
C says so in writing.  Everyone is granted permission to copy, modify  %
C and redistribute the programs in GSLIB, but only under the condition %
C that this notice and the above copyright notice remain intact.       %
C                                                                      %
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
c-----------------------------------------------------------------------
c
c    Squared Anisotropic Distance Calculation Given Matrix Indicator
c    ***************************************************************
c
c This routine calculates the anisotropic distance between two points
c  given the coordinates of each point and a definition of the
c  anisotropy.
c
c
c INPUT VARIABLES:
c
c   x1,y1,z1         Coordinates of first point
c   x2,y2,z2         Coordinates of second point
c   ind              The rotation matrix to use
c   MAXROT           The maximum number of rotation matrices dimensioned
c   rotmat           The rotation matrices
c
c
c
c OUTPUT VARIABLES:
c
c   sqdist           The squared distance accounting for the anisotropy
c                      and the rotation of coordinates (if any).
c
c
c NO EXTERNAL REFERENCES
c
c
c-----------------------------------------------------------------------
      real*8 rotmat(MAXROT,3,3),cont,dx,dy,dz
c
c Compute component distance vectors and the squared distance:
c
      dx = dble(x1 - x2)
      dy = dble(y1 - y2)
      dz = dble(z1 - z2)
      sqdist = 0.0
      do i=1,3
            cont   = rotmat(ind,i,1) * dx
     +             + rotmat(ind,i,2) * dy
     +             + rotmat(ind,i,3) * dz
            sqdist = sqdist + cont * cont
      end do
      return
      end


      subroutine wconstruct(etvec,plept,lepton,etmissing)
      implicit none
      include 'constants.f'
      include 'masses.f'
      double precision etvec(2),plept(4),pw(4),etmissing(4),
     . pte,ptn,ptwsq,a,b,discr,plnp,plnm,Ee,ple,mtsq,Enp,Enm
      double precision yrap1,yrap2
      integer j
      character*2 lepton

      do j=1,2
        pw(j)=plept(j)+etvec(j)
        etmissing(j)=etvec(j)
      enddo

      pte=dsqrt(plept(1)**2+plept(2)**2)
      ptn=dsqrt(etvec(1)**2+etvec(2)**2)
      ptwsq=(pw(1)**2+pw(2)**2)
      Ee=plept(4)
      ple=plept(3)
      mtsq=(pte+ptn)**2-ptwsq

c  + (Mw^2 - MT^2) * Ee^2 * ( 4*pte*ptn + Mw^2 - Mt^2 )
c
c - pln
c  * ple*( 2*pte*ptn + Mw^2 - MT^2 )
c
c + pln^2
c  * ( pte^2 ) + 0.

c      write(6,*) 'wmass**2,mtsq',wmass**2,mtsq
      if (wmass**2 .gt. mtsq) then
        discr=Ee*dsqrt((wmass**2-mtsq)*(wmass**2-mtsq+4d0*pte*ptn))
        a=pte**2
        b=-(2d0*pte*ptn+wmass**2-mtsq)*ple
c      c=-0.25d0*(wmass**2-mtsq+2*pte*ptn)**2
c     # +ptn**2*Ee**2
c      write(6,*) 'discr',sqrt(b**2-4*a*c),discr
      else
        discr=0d0
        a=pte**2
        b=-2*pte*ptn*ple
      endif

c      wsq=pw(4)**2-pw(1)**2-pw(2)**2-pw(3)**2
c      write(6,*) 'cal:mw',wsq,plntrue
      plnp=(-b+discr)/(two*a)
      plnm=(-b-discr)/(two*a)

      Enm=dsqrt(plnm**2+ptn**2)
      Enp=dsqrt(plnp**2+ptn**2)
      yrap1=(Enm+plnm)/(Enm-plnm)
      yrap2=(Enp+plnp)/(Enp-plnp)
      if (yrap1 .lt. 1d-13) then
        yrap1=100d0
      else
        yrap1=0.5d0*dlog(yrap1)
      endif
      if (yrap2 .lt. 1d-13) then
        yrap2=100d0
      else
        yrap2=0.5d0*dlog(yrap2)
      endif

      if     ((lepton.eq.'ea') .or. (lepton.eq.'ma')) then
c--- choose the solution with the larger rapidity
        if (yrap1 .gt. yrap2) then
          etmissing(4)=Enm
          etmissing(3)=plnm
        else
          etmissing(4)=Enp
          etmissing(3)=plnp
        endif
      elseif ((lepton.eq.'el') .or. (lepton.eq.'ml')) then
c--- choose the solution with the smaller rapidity
        if (yrap1 .lt. yrap2) then
          etmissing(4)=Enm
          etmissing(3)=plnm
        else
          etmissing(4)=Enp
          etmissing(3)=plnp
        endif
      else
        write(6,*) 'Problem: not a lepton in wconstruct!'
        stop
      endif

      return
      end


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

      MODULE m_visp5_z
      CONTAINS
      SUBROUTINE visp5_z(
     >             nmzxyd,nmzxy,delz,m,ivfft1,ivfft2,IIIR,
     >             rxy,ani1,ani2,z1,amat,pvac,pint,tpi,l,
     >             fpi,val_help,III,m1,gz,rmap,rr,
     <             vis_help)

      USE m_qsf
      USE m_angle
      USE m_modcyli
      IMPLICIT NONE

c---- this subroutine generates the gz.ne.0 components of the
c---- \tilde\tilde{V} potential on the
c --- uniform grid in the unit cell \tilde{\Omega} for further 2-
c---- dimensional fast fourier transform
c---- for the further understanding look at the vvacxy_4.F
c----                        Y.Mokrousov

      INTEGER, INTENT (IN) :: nmzxyd,nmzxy,m,ivfft1,ivfft2,l,m1
      REAL,    INTENT (IN) :: ani1,ani2,delz,z1,IIIR,tpi,fpi
      REAL,    INTENT (IN) :: III(ivfft1*ivfft2)
      REAL,    INTENT (IN) :: amat(3,3),gz
      COMPLEX, INTENT (IN) :: rxy(nmzxyd)
      COMPLEX, INTENT (IN) :: pvac(nmzxyd)
      COMPLEX, INTENT (IN) :: pint(nmzxyd)
      COMPLEX, INTENT (IN) :: val_help
      INTEGER, INTENT (IN) :: rmap(0:ivfft1-1,0:ivfft2-1)
      REAL,    INTENT (IN) :: rr(ivfft1*ivfft2)
      COMPLEX, INTENT (OUT)::
     &           vis_help(0:ivfft1-1,0:ivfft2-1)

      INTEGER imz,ix,iy,im,mult,irc
      REAL    x,y,r,phi,zf,q

      INTRINSIC real,aimag

      mult = (-1)**(l+1)

      DO ix = 0,ivfft1 - 1
         DO iy = 0,ivfft2 - 1
            x = ix*ani1
            IF (x.GT.0.5) x = x - 1.
            y = iy*ani2
            IF (y.GT.0.5) y = y - 1.
               r = sqrt((x*amat(1,1) + y*amat(1,2))**2 +
     +                  (x*amat(2,1) + y*amat(2,2))**2)
               phi = angle(x*amat(1,1) + y*amat(1,2),
     >                     x*amat(2,1) + y*amat(2,2))
            irc = rmap(ix,iy)
            r = rr(irc)
            IF (r.GT.z1) THEN
               zf = (r-z1)/delz + 1.0
               im = zf
               q = zf - im
               vis_help(ix,iy) =
     +              (0.5* (q-1.)*
     *              (q-2.)*(pvac(im)+pint(im)) -
     +              q* (q-2.)*(pvac(im+1)
     +              +pint(im+1))+
     +              0.5*q* (q-1.)*(pvac(im+2)
     +              +pint(im+2)))*
     +              exp(cmplx(0.,mult*m*phi))
            ELSE
               vis_help(ix,iy) =
     *              III(irc)*(val_help)*
     *              exp(cmplx(0.,m1*phi))/IIIR

            END IF

         END DO                 ! ix
      END DO                    ! iy

      END SUBROUTINE visp5_z
      END MODULE m_visp5_z


! PR tree-optimization/69155
! { dg-do compile }

function pr69155 (a, b)
  complex(kind=8), value :: a, b
  if (dimag (a) .lt. 10) then
  1 continue
    if (dble (a) .lt. 10) then
      b = b - 1 / a
      a = a + 1
      goto 1
    end if
  end if
  pr69155 = a + b
end


module body
  ! - Module to create and initialize "planetary_body" type objects.
  ! - These objects are described by position, velocity, force, and mass.
  ! - Position, velocity and force are 3D-vectors. Their values are
  !   saved for each time step.
  implicit none

  type planetary_body
     real(8), dimension(:,:), allocatable :: pos ! position (x,y,z) [m]
     real(8), dimension(:,:), allocatable :: vel ! velocity (dx,dy,dz) [m/s]
     real(8), dimension(:,:), allocatable :: f   ! force (dx,dy,dz) [N]
     real(8) :: mass                             ! mass [kg]
  end type planetary_body

contains

  subroutine create_body(body,n)
    ! create body type structure
    ! with n-steps of information + (inital state)
    implicit none
    integer, intent(in) :: n
    type(planetary_body), intent(inout) :: body
    if (allocated(body%pos)) deallocate(body%pos)
    if (allocated(body%vel)) deallocate(body%vel)
    if (allocated(body%f)) deallocate(body%f)
    allocate(body%pos(n+1,3))
    allocate(body%vel(n+1,3))
    allocate(body%f(n+1,3))
  end subroutine create_body

  subroutine init_body(body,pos,vel,mass,nsteps)
    ! initial state of the body (with mass, position, velocity)
    implicit none
    type(planetary_body), intent(inout) :: body
    real(8), dimension(3), intent(in) :: pos, vel
    real(8), intent(in) :: mass
    integer, intent(in) :: nsteps
    call create_body(body,nsteps)
    body%mass = mass
    body%pos(1,:) = pos
    body%vel(1,:) = vel
  end subroutine init_body

  subroutine get_body_fields(body,n,pos,vel,f,mass)
    ! returns position, velocity, force and mass of
    ! a object at the time step n
    implicit none
    integer, intent(in) :: n
    type(planetary_body), intent(inout) :: body
    real(8), dimension(3), intent(out) :: pos, vel, f
    real(8), intent(out) :: mass
    pos = body%pos(n,:)
    vel = body%vel(n,:)
    f = body%f(n,:)
    mass = body%mass
  end subroutine get_body_fields

  subroutine init_n_body_system(bodies,nbodies)
    ! computes initial forces of a N body system
    ! using Newton's universal law of gravity
    use math,only : newton
    implicit none
    integer, intent(in) :: nbodies
    type(planetary_body), dimension(nbodies), intent(inout) :: bodies
    real(8), dimension(nbodies,3) :: pos
    real(8), dimension(nbodies) :: mass
    integer :: n
    real(8), dimension(nbodies,3) :: f
    ! initial positions and masses
    do n=1, nbodies
       pos(n,:) = bodies(n)%pos(1,:)
       mass(n) = bodies(n)%mass
    end do
    ! initial forces
    f = calc_forces(mass,pos,nbodies)
    do n=1, nbodies
       bodies(n)%f(1,:) = f(n,:)
    end do
  end subroutine init_n_body_system

  function calc_forces(mass,pos,nbodies) result(f)
    ! calculate forces between N-bodies
    use math, only : newton
    implicit none
    integer, intent(in) :: nbodies
    real(8), dimension(nbodies), intent(in) :: mass
    real(8), dimension(nbodies,3), intent(in) :: pos
    real(8), dimension(nbodies,3) :: f
    integer :: n, m, i1, i2
    f = 0.0
    do n=1, nbodies
       do m=1, nbodies-1
          i1 = n
          i2 = m
          if (m>=n) i2 = i2+1
          f(n,:) = f(n,:) + newton(mass(i2),mass(i1),pos(i2,:),pos(i1,:))
       end do
    end do
  end function calc_forces

end module body


!
!===============================================================================
!-- elasticity Module Tests
!> Tests for elasticity_mod module
!===============================================================================
!/****/h* modules|elasticity/test_elasticity_mod
!* SYNOPSIS
MODULE test_elasticity_mod
!* PURPOSE
!*   Tests for elasticity_mod module
!* INCLUDES
!*   elasticity_mod
!* CONTAINS
!*   Subroutine              Purpose
!*   elasticity_tests(cnt)
!* AUTHOR
!*   Pieter Boom
!* MODIFICATION HISTORY
!*   2019/08/21: Created (PB)
!* COPYRIGHT
!*   (c) University of Manchester
!******/
!> author: Pieter Boom
!> date: 2019/08/21
!> Tests for elasticity_mod module
!===============================================================================

  !-----------------------------------------------------------------------------
  ! use statements and implicit none
  !-----------------------------------------------------------------------------
  USE elasticity_mod

  IMPLICIT NONE

!===============================================================================
CONTAINS
!===============================================================================
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! /****s*/ /src/elasticity/test_elasticity_mod|elasticity_test
!* SYNOPSIS
  SUBROUTINE elasticity_tests(cnt)
!* PURPOSE
!*   tests elasticity_mod
!* INPUTS
!*   test counter
!* OUTPUTS
!*   test counter
!* AUTHOR
!*   Pieter Boom
!* MODIFICATION HISTORY
!*   2019/08/21: Created (PB)
!* COPYRIGHT
!*   (c) University of Manchester
!******/
!> author: Pieter Boom
!> date: 2019/08/21
!> tests elasticity_mod
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    IMPLICIT NONE

    !---------------------------------------------------------------------
    ! arguments
    !---------------------------------------------------------------------
    INTEGER, INTENT(INOUT) :: cnt             !> test counter

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! MAIN EXECUTION
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    !---------------------------------------------------------------------
    !*   Subroutine              Purpose
    !---------------------------------------------------------------------

  END SUBROUTINE
! test_elasticity_mod|elasticity_test
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!

END MODULE
! elasticity_test
!===============================================================================
!


program ch0509
    ! Using the Numeric Inquiry Functions with Integer Types
    implicit none

    integer :: i
    integer, parameter :: i8 = selected_int_kind(2)
    integer, parameter :: i16 = selected_int_kind(4)
    integer, parameter :: i32 = selected_int_kind(9)
    integer, parameter :: i64 = selected_int_kind(18)
    integer(i8) :: i1
    integer(i16) :: i2
    integer(i32) :: i3
    integer(i64) :: i4

    print *, ' '
    print *, ' integer kind support'
    print *, ' kind            huge'
    print *, ' '
    print *, ' ', kind(i), ' ', huge(i)
    print *, ' ', kind(i1), ' ', huge(i1)
    print *, ' ', kind(i2), ' ', huge(i2)
    print *, ' ', kind(i3), ' ', huge(i3)
    print *, ' ', kind(i4), ' ', huge(i4)
    print *, ' '
end program


!**
!* Provides kinds used by all modules of this package.
!* This module can be understood as an interface to integrate this package in other projects.
!**
module kinds
    implicit none
    private
    public :: dp

    integer, parameter :: dp = selected_real_kind(p=15,r=30)
end module kinds


      PROGRAM xran
C     driver for routines ran0, ran1, ran2, ran3
      REAL ran0,ran1,ran2,ran3
      EXTERNAL ran0,ran1,ran2,ran3
      write(*,*)
      write(*,*) 'Testing ran0:'
      call integ(ran0)
      write(*,*)
      write(*,*) 'Testing ran1:'
      call integ(ran1)
      write(*,*)
      write(*,*) 'Testing ran2:'
      call integ(ran2)
      write(*,*)
      write(*,*) 'Testing ran3:'
      call integ(ran3)
      END
      SUBROUTINE integ(func)
C     calculates pi statistically using volume of unit n-sphere
      REAL PI
      PARAMETER(PI=3.1415926)
      INTEGER i,idum,j,k,iy(3)
      REAL fnc,func,x1,x2,x3,x4,yprob(3)
      EXTERNAL func
      fnc(x1,x2,x3,x4)=sqrt(x1**2+x2**2+x3**2+x4**2)
      idum=-1
      do 11 i=1,3
        iy(i)=0
11    continue
      write(*,'(1x,t15,a)') 'Volume of unit n-sphere, n = 2, 3, 4'
      write(*,'(1x,/,t3,a,t17,a,t26,a,t37,a)')
     *     '# points','PI','(4/3)*PI','(1/2)*PI^2'
      do 14 j=1,15
        do 12 k=2**(j-1),0,-1
          x1=func(idum)
          x2=func(idum)
          x3=func(idum)
          x4=func(idum)
          if (fnc(x1,x2,0.0,0.0).lt.1.0) iy(1)=iy(1)+1
          if (fnc(x1,x2,x3,0.0).lt.1.0) iy(2)=iy(2)+1
          if (fnc(x1,x2,x3,x4).lt.1.0) iy(3)=iy(3)+1
12      continue
        do 13 i=1,3
          yprob(i)=1.0*(2**(i+1))*iy(i)/(2**j)
13      continue
        write(*,'(1x,i8,3f12.6)') 2**j,(yprob(i),i=1,3)
14    continue
      write(*,'(1x,/,t4,a,3f12.6,/)') 'actual',PI,4.0*PI/3.0,0.5*(PI**2)
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xran.for


    Subroutine nagf_blas_zddscl(n, d, incd, x, incx)

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     NAGF_BLAS_ZDDSCL performs the operation

!     x := diag( d )*x

!     Nag Fortran 77 O( n ) basic linear algebra routine.

!     -- Written on 12-February-1986.
!     Sven Hammarling, Nag Central Office.

!     .. Use Statements ..
      Use blas_interfaces, Only: zdscal
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Scalar Arguments ..
      Integer, Intent (In) :: incd, incx, n
!     .. Array Arguments ..
      Complex (Kind=dp), Intent (Inout) :: x(*)
      Real (Kind=dp), Intent (In) :: d(*)
!     .. Local Scalars ..
      Integer :: i, id, ix
!     .. Intrinsic Procedures ..
      Intrinsic :: abs, cmplx
!     .. Executable Statements ..
      Continue

      If (n>0) Then
        If ((incd==0) .And. (incx/=0)) Then
          Call zdscal(n=n, alpha=d(1), x=x, incx=abs(incx))
        Else If ((incd==incx) .And. (incd>0)) Then
          Do id = 1, 1 + (n-1)*incd, incd
            x(id) = cmplx(d(id), kind=dp)*x(id)
          End Do
        Else
          If (incx>=0) Then
            ix = 1
          Else
            ix = 1 - (n-1)*incx
          End If
          If (incd>0) Then
            Do id = 1, 1 + (n-1)*incd, incd
              x(ix) = cmplx(d(id), kind=dp)*x(ix)
              ix = ix + incx
            End Do
          Else
            id = 1 - (n-1)*incd
            Do i = 1, n
              x(ix) = cmplx(d(id), kind=dp)*x(ix)
              id = id + incd
              ix = ix + incx
            End Do
          End If
        End If
      End If

      Return

!     End of NAGF_BLAS_ZDDSCL.

    End Subroutine


*DECK DASUM
      DOUBLE PRECISION FUNCTION DASUM (N, DX, INCX)
C***BEGIN PROLOGUE  DASUM
C***PURPOSE  Compute the sum of the magnitudes of the elements of a
C            vector.
C***LIBRARY   SLATEC (BLAS)
C***CATEGORY  D1A3A
C***TYPE      DOUBLE PRECISION (SASUM-S, DASUM-D, SCASUM-C)
C***KEYWORDS  BLAS, LINEAR ALGEBRA, SUM OF MAGNITUDES OF A VECTOR
C***AUTHOR  Lawson, C. L., (JPL)
C           Hanson, R. J., (SNLA)
C           Kincaid, D. R., (U. of Texas)
C           Krogh, F. T., (JPL)
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       DX  double precision vector with N elements
C     INCX  storage spacing between elements of DX
C
C     --Output--
C    DASUM  double precision result (zero if N .LE. 0)
C
C     Returns sum of magnitudes of double precision DX.
C     DASUM = sum from 0 to N-1 of ABS(DX(IX+I*INCX)),
C     where IX = 1 if INCX .GE. 0, else IX = 1+(1-N)*INCX.
C
C***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
C                 Krogh, Basic linear algebra subprograms for Fortran
C                 usage, Algorithm No. 539, Transactions on Mathematical
C                 Software 5, 3 (September 1979), pp. 308-323.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   791001  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
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   900821  Modified to correct problem with a negative increment.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DASUM
      DOUBLE PRECISION DX(*)
      INTEGER I, INCX, IX, M, MP1, N
C***FIRST EXECUTABLE STATEMENT  DASUM
      DASUM = 0.0D0
      IF (N .LE. 0) RETURN
C
      IF (INCX .EQ. 1) GOTO 20
C
C     Code for increment not equal to 1.
C
      IX = 1
      IF (INCX .LT. 0) IX = (-N+1)*INCX + 1
      DO 10 I = 1,N
        DASUM = DASUM + ABS(DX(IX))
        IX = IX + INCX
   10 CONTINUE
      RETURN
C
C     Code for increment equal to 1.
C
C     Clean-up loop so remaining vector length is a multiple of 6.
C
   20 M = MOD(N,6)
      IF (M .EQ. 0) GOTO 40
      DO 30 I = 1,M
        DASUM = DASUM + ABS(DX(I))
   30 CONTINUE
      IF (N .LT. 6) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,6
        DASUM = DASUM + ABS(DX(I)) + ABS(DX(I+1)) + ABS(DX(I+2)) +
     1          ABS(DX(I+3)) + ABS(DX(I+4)) + ABS(DX(I+5))
   50 CONTINUE
      RETURN
      END
*DECK DAXPY
      SUBROUTINE DAXPY (N, DA, DX, INCX, DY, INCY)
C***BEGIN PROLOGUE  DAXPY
C***PURPOSE  Compute a constant times a vector plus a vector.
C***LIBRARY   SLATEC (BLAS)
C***CATEGORY  D1A7
C***TYPE      DOUBLE PRECISION (SAXPY-S, DAXPY-D, CAXPY-C)
C***KEYWORDS  BLAS, LINEAR ALGEBRA, TRIAD, VECTOR
C***AUTHOR  Lawson, C. L., (JPL)
C           Hanson, R. J., (SNLA)
C           Kincaid, D. R., (U. of Texas)
C           Krogh, F. T., (JPL)
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       DA  double precision scalar multiplier
C       DX  double precision vector with N elements
C     INCX  storage spacing between elements of DX
C       DY  double precision vector with N elements
C     INCY  storage spacing between elements of DY
C
C     --Output--
C       DY  double precision result (unchanged if N .LE. 0)
C
C     Overwrite double precision DY with double precision DA*DX + DY.
C     For I = 0 to N-1, replace  DY(LY+I*INCY) with DA*DX(LX+I*INCX) +
C       DY(LY+I*INCY),
C     where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is
C     defined in a similar way using INCY.
C
C***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
C                 Krogh, Basic linear algebra subprograms for Fortran
C                 usage, Algorithm No. 539, Transactions on Mathematical
C                 Software 5, 3 (September 1979), pp. 308-323.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   791001  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   920310  Corrected definition of LX in DESCRIPTION.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DAXPY
      DOUBLE PRECISION DX(*), DY(*), DA
C***FIRST EXECUTABLE STATEMENT  DAXPY
      IF (N.LE.0 .OR. DA.EQ.0.0D0) RETURN
      IF (INCX .EQ. INCY) IF (INCX-1) 5,20,60
C
C     Code for unequal or nonpositive increments.
C
    5 IX = 1
      IY = 1
      IF (INCX .LT. 0) IX = (-N+1)*INCX + 1
      IF (INCY .LT. 0) IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DY(IY) = DY(IY) + DA*DX(IX)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C     Code for both increments equal to 1.
C
C     Clean-up loop so remaining vector length is a multiple of 4.
C
   20 M = MOD(N,4)
      IF (M .EQ. 0) GO TO 40
      DO 30 I = 1,M
        DY(I) = DY(I) + DA*DX(I)
   30 CONTINUE
      IF (N .LT. 4) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,4
        DY(I) = DY(I) + DA*DX(I)
        DY(I+1) = DY(I+1) + DA*DX(I+1)
        DY(I+2) = DY(I+2) + DA*DX(I+2)
        DY(I+3) = DY(I+3) + DA*DX(I+3)
   50 CONTINUE
      RETURN
C
C     Code for equal, positive, non-unit increments.
C
   60 NS = N*INCX
      DO 70 I = 1,NS,INCX
        DY(I) = DA*DX(I) + DY(I)
   70 CONTINUE
      RETURN
      END
*DECK DCOPY
      SUBROUTINE DCOPY (N, DX, INCX, DY, INCY)
C***BEGIN PROLOGUE  DCOPY
C***PURPOSE  Copy a vector.
C***LIBRARY   SLATEC (BLAS)
C***CATEGORY  D1A5
C***TYPE      DOUBLE PRECISION (SCOPY-S, DCOPY-D, CCOPY-C, ICOPY-I)
C***KEYWORDS  BLAS, COPY, LINEAR ALGEBRA, VECTOR
C***AUTHOR  Lawson, C. L., (JPL)
C           Hanson, R. J., (SNLA)
C           Kincaid, D. R., (U. of Texas)
C           Krogh, F. T., (JPL)
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       DX  double precision vector with N elements
C     INCX  storage spacing between elements of DX
C       DY  double precision vector with N elements
C     INCY  storage spacing between elements of DY
C
C     --Output--
C       DY  copy of vector DX (unchanged if N .LE. 0)
C
C     Copy double precision DX to double precision DY.
C     For I = 0 to N-1, copy DX(LX+I*INCX) to DY(LY+I*INCY),
C     where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is
C     defined in a similar way using INCY.
C
C***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
C                 Krogh, Basic linear algebra subprograms for Fortran
C                 usage, Algorithm No. 539, Transactions on Mathematical
C                 Software 5, 3 (September 1979), pp. 308-323.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   791001  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   920310  Corrected definition of LX in DESCRIPTION.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DCOPY
      DOUBLE PRECISION DX(*), DY(*)
C***FIRST EXECUTABLE STATEMENT  DCOPY
      IF (N .LE. 0) RETURN
      IF (INCX .EQ. INCY) IF (INCX-1) 5,20,60
C
C     Code for unequal or nonpositive increments.
C
    5 IX = 1
      IY = 1
      IF (INCX .LT. 0) IX = (-N+1)*INCX + 1
      IF (INCY .LT. 0) IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DY(IY) = DX(IX)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C     Code for both increments equal to 1.
C
C     Clean-up loop so remaining vector length is a multiple of 7.
C
   20 M = MOD(N,7)
      IF (M .EQ. 0) GO TO 40
      DO 30 I = 1,M
        DY(I) = DX(I)
   30 CONTINUE
      IF (N .LT. 7) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,7
        DY(I) = DX(I)
        DY(I+1) = DX(I+1)
        DY(I+2) = DX(I+2)
        DY(I+3) = DX(I+3)
        DY(I+4) = DX(I+4)
        DY(I+5) = DX(I+5)
        DY(I+6) = DX(I+6)
   50 CONTINUE
      RETURN
C
C     Code for equal, positive, non-unit increments.
C
   60 NS = N*INCX
      DO 70 I = 1,NS,INCX
        DY(I) = DX(I)
   70 CONTINUE
      RETURN
      END
*DECK DDOT
      DOUBLE PRECISION FUNCTION DDOT (N, DX, INCX, DY, INCY)
C***BEGIN PROLOGUE  DDOT
C***PURPOSE  Compute the inner product of two vectors.
C***LIBRARY   SLATEC (BLAS)
C***CATEGORY  D1A4
C***TYPE      DOUBLE PRECISION (SDOT-S, DDOT-D, CDOTU-C)
C***KEYWORDS  BLAS, INNER PRODUCT, LINEAR ALGEBRA, VECTOR
C***AUTHOR  Lawson, C. L., (JPL)
C           Hanson, R. J., (SNLA)
C           Kincaid, D. R., (U. of Texas)
C           Krogh, F. T., (JPL)
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       DX  double precision vector with N elements
C     INCX  storage spacing between elements of DX
C       DY  double precision vector with N elements
C     INCY  storage spacing between elements of DY
C
C     --Output--
C     DDOT  double precision dot product (zero if N .LE. 0)
C
C     Returns the dot product of double precision DX and DY.
C     DDOT = sum for I = 0 to N-1 of  DX(LX+I*INCX) * DY(LY+I*INCY),
C     where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is
C     defined in a similar way using INCY.
C
C***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
C                 Krogh, Basic linear algebra subprograms for Fortran
C                 usage, Algorithm No. 539, Transactions on Mathematical
C                 Software 5, 3 (September 1979), pp. 308-323.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   791001  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   920310  Corrected definition of LX in DESCRIPTION.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DDOT
      DOUBLE PRECISION DX(*), DY(*)
C***FIRST EXECUTABLE STATEMENT  DDOT
      DDOT = 0.0D0
      IF (N .LE. 0) RETURN
      IF (INCX .EQ. INCY) IF (INCX-1) 5,20,60
C
C     Code for unequal or nonpositive increments.
C
    5 IX = 1
      IY = 1
      IF (INCX .LT. 0) IX = (-N+1)*INCX + 1
      IF (INCY .LT. 0) IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DDOT = DDOT + DX(IX)*DY(IY)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C     Code for both increments equal to 1.
C
C     Clean-up loop so remaining vector length is a multiple of 5.
C
   20 M = MOD(N,5)
      IF (M .EQ. 0) GO TO 40
      DO 30 I = 1,M
         DDOT = DDOT + DX(I)*DY(I)
   30 CONTINUE
      IF (N .LT. 5) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,5
      DDOT = DDOT + DX(I)*DY(I) + DX(I+1)*DY(I+1) + DX(I+2)*DY(I+2) +
     1              DX(I+3)*DY(I+3) + DX(I+4)*DY(I+4)
   50 CONTINUE
      RETURN
C
C     Code for equal, positive, non-unit increments.
C
   60 NS = N*INCX
      DO 70 I = 1,NS,INCX
        DDOT = DDOT + DX(I)*DY(I)
   70 CONTINUE
      RETURN
      END
*DECK DNRM2
      DOUBLE PRECISION FUNCTION DNRM2 (N, DX, INCX)
C***BEGIN PROLOGUE  DNRM2
C***PURPOSE  Compute the Euclidean length (L2 norm) of a vector.
C***LIBRARY   SLATEC (BLAS)
C***CATEGORY  D1A3B
C***TYPE      DOUBLE PRECISION (SNRM2-S, DNRM2-D, SCNRM2-C)
C***KEYWORDS  BLAS, EUCLIDEAN LENGTH, EUCLIDEAN NORM, L2,
C             LINEAR ALGEBRA, UNITARY, VECTOR
C***AUTHOR  Lawson, C. L., (JPL)
C           Hanson, R. J., (SNLA)
C           Kincaid, D. R., (U. of Texas)
C           Krogh, F. T., (JPL)
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       DX  double precision vector with N elements
C     INCX  storage spacing between elements of DX
C
C     --Output--
C    DNRM2  double precision result (zero if N .LE. 0)
C
C     Euclidean norm of the N-vector stored in DX with storage
C     increment INCX.
C     If N .LE. 0, return with result = 0.
C     If N .GE. 1, then INCX must be .GE. 1
C
C     Four phase method using two built-in constants that are
C     hopefully applicable to all machines.
C         CUTLO = maximum of  SQRT(U/EPS)  over all known machines.
C         CUTHI = minimum of  SQRT(V)      over all known machines.
C     where
C         EPS = smallest no. such that EPS + 1. .GT. 1.
C         U   = smallest positive no.   (underflow limit)
C         V   = largest  no.            (overflow  limit)
C
C     Brief outline of algorithm.
C
C     Phase 1 scans zero components.
C     move to phase 2 when a component is nonzero and .LE. CUTLO
C     move to phase 3 when a component is .GT. CUTLO
C     move to phase 4 when a component is .GE. CUTHI/M
C     where M = N for X() real and M = 2*N for complex.
C
C     Values for CUTLO and CUTHI.
C     From the environmental parameters listed in the IMSL converter
C     document the limiting values are as follows:
C     CUTLO, S.P.   U/EPS = 2**(-102) for  Honeywell.  Close seconds are
C                   Univac and DEC at 2**(-103)
C                   Thus CUTLO = 2**(-51) = 4.44089E-16
C     CUTHI, S.P.   V = 2**127 for Univac, Honeywell, and DEC.
C                   Thus CUTHI = 2**(63.5) = 1.30438E19
C     CUTLO, D.P.   U/EPS = 2**(-67) for Honeywell and DEC.
C                   Thus CUTLO = 2**(-33.5) = 8.23181D-11
C     CUTHI, D.P.   same as S.P.  CUTHI = 1.30438D19
C     DATA CUTLO, CUTHI /8.232D-11,  1.304D19/
C     DATA CUTLO, CUTHI /4.441E-16,  1.304E19/
C
C***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
C                 Krogh, Basic linear algebra subprograms for Fortran
C                 usage, Algorithm No. 539, Transactions on Mathematical
C                 Software 5, 3 (September 1979), pp. 308-323.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   791001  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
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   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DNRM2
      INTEGER NEXT
      DOUBLE PRECISION DX(*), CUTLO, CUTHI, HITEST, SUM, XMAX, ZERO,
     +                 ONE
      SAVE CUTLO, CUTHI, ZERO, ONE
      DATA ZERO, ONE /0.0D0, 1.0D0/
C
      DATA CUTLO, CUTHI /8.232D-11,  1.304D19/
C***FIRST EXECUTABLE STATEMENT  DNRM2
      IF (N .GT. 0) GO TO 10
         DNRM2  = ZERO
         GO TO 300
C
   10 ASSIGN 30 TO NEXT
      SUM = ZERO
      NN = N * INCX
C
C                                                 BEGIN MAIN LOOP
C
      I = 1
   20    GO TO NEXT,(30, 50, 70, 110)
   30 IF (ABS(DX(I)) .GT. CUTLO) GO TO 85
      ASSIGN 50 TO NEXT
      XMAX = ZERO
C
C                        PHASE 1.  SUM IS ZERO
C
   50 IF (DX(I) .EQ. ZERO) GO TO 200
      IF (ABS(DX(I)) .GT. CUTLO) GO TO 85
C
C                                PREPARE FOR PHASE 2.
C
      ASSIGN 70 TO NEXT
      GO TO 105
C
C                                PREPARE FOR PHASE 4.
C
  100 I = J
      ASSIGN 110 TO NEXT
      SUM = (SUM / DX(I)) / DX(I)
  105 XMAX = ABS(DX(I))
      GO TO 115
C
C                   PHASE 2.  SUM IS SMALL.
C                             SCALE TO AVOID DESTRUCTIVE UNDERFLOW.
C
   70 IF (ABS(DX(I)) .GT. CUTLO) GO TO 75
C
C                     COMMON CODE FOR PHASES 2 AND 4.
C                     IN PHASE 4 SUM IS LARGE.  SCALE TO AVOID OVERFLOW.
C
  110 IF (ABS(DX(I)) .LE. XMAX) GO TO 115
         SUM = ONE + SUM * (XMAX / DX(I))**2
         XMAX = ABS(DX(I))
         GO TO 200
C
  115 SUM = SUM + (DX(I)/XMAX)**2
      GO TO 200
C
C                  PREPARE FOR PHASE 3.
C
   75 SUM = (SUM * XMAX) * XMAX
C
C     FOR REAL OR D.P. SET HITEST = CUTHI/N
C     FOR COMPLEX      SET HITEST = CUTHI/(2*N)
C
   85 HITEST = CUTHI / N
C
C                   PHASE 3.  SUM IS MID-RANGE.  NO SCALING.
C
      DO 95 J = I,NN,INCX
      IF (ABS(DX(J)) .GE. HITEST) GO TO 100
   95    SUM = SUM + DX(J)**2
      DNRM2 = SQRT(SUM)
      GO TO 300
C
  200 CONTINUE
      I = I + INCX
      IF (I .LE. NN) GO TO 20
C
C              END OF MAIN LOOP.
C
C              COMPUTE SQUARE ROOT AND ADJUST FOR SCALING.
C
      DNRM2 = XMAX * SQRT(SUM)
  300 CONTINUE
      RETURN
      END
*DECK DROTM
      SUBROUTINE DROTM (N, DX, INCX, DY, INCY, DPARAM)
C***BEGIN PROLOGUE  DROTM
C***PURPOSE  Apply a modified Givens transformation.
C***LIBRARY   SLATEC (BLAS)
C***CATEGORY  D1A8
C***TYPE      DOUBLE PRECISION (SROTM-S, DROTM-D)
C***KEYWORDS  BLAS, LINEAR ALGEBRA, MODIFIED GIVENS ROTATION, VECTOR
C***AUTHOR  Lawson, C. L., (JPL)
C           Hanson, R. J., (SNLA)
C           Kincaid, D. R., (U. of Texas)
C           Krogh, F. T., (JPL)
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       DX  double precision vector with N elements
C     INCX  storage spacing between elements of DX
C       DY  double precision vector with N elements
C     INCY  storage spacing between elements of DY
C   DPARAM  5-element D.P. vector.  DPARAM(1) is DFLAG described below.
C           Locations 2-5 of SPARAM contain elements of the
C           transformation matrix H described below.
C
C     --Output--
C       DX  rotated vector (unchanged if N .LE. 0)
C       DY  rotated vector (unchanged if N .LE. 0)
C
C     Apply the modified Givens transformation, H, to the 2 by N matrix
C     (DX**T)
C     (DY**T) , where **T indicates transpose.  The elements of DX are
C     in DX(LX+I*INCX), I = 0 to N-1, where LX = 1 if INCX .GE. 0, else
C     LX = 1+(1-N)*INCX, and similarly for DY using LY and INCY.
C
C     With DPARAM(1)=DFLAG, H has one of the following forms:
C
C     DFLAG=-1.D0     DFLAG=0.D0        DFLAG=1.D0     DFLAG=-2.D0
C
C       (DH11  DH12)    (1.D0  DH12)    (DH11  1.D0)    (1.D0  0.D0)
C     H=(          )    (          )    (          )    (          )
C       (DH21  DH22),   (DH21  1.D0),   (-1.D0 DH22),   (0.D0  1.D0).
C
C     See DROTMG for a description of data storage in DPARAM.
C
C***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
C                 Krogh, Basic linear algebra subprograms for Fortran
C                 usage, Algorithm No. 539, Transactions on Mathematical
C                 Software 5, 3 (September 1979), pp. 308-323.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   791001  DATE WRITTEN
C   861211  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920310  Corrected definition of LX in DESCRIPTION.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DROTM
      DOUBLE PRECISION DFLAG, DH12, DH22, DX, TWO, Z, DH11, DH21,
     1                 DPARAM, DY, W, ZERO
      DIMENSION DX(*), DY(*), DPARAM(5)
      SAVE ZERO, TWO
      DATA ZERO, TWO /0.0D0, 2.0D0/
C***FIRST EXECUTABLE STATEMENT  DROTM
      DFLAG=DPARAM(1)
      IF (N.LE.0 .OR. (DFLAG+TWO.EQ.ZERO)) GO TO 140
          IF (.NOT.(INCX.EQ.INCY.AND. INCX .GT.0)) GO TO 70
C
               NSTEPS=N*INCX
               IF (DFLAG) 50,10,30
   10          CONTINUE
               DH12=DPARAM(4)
               DH21=DPARAM(3)
                    DO 20 I = 1,NSTEPS,INCX
                    W=DX(I)
                    Z=DY(I)
                    DX(I)=W+Z*DH12
                    DY(I)=W*DH21+Z
   20               CONTINUE
               GO TO 140
   30          CONTINUE
               DH11=DPARAM(2)
               DH22=DPARAM(5)
                    DO 40 I = 1,NSTEPS,INCX
                    W=DX(I)
                    Z=DY(I)
                    DX(I)=W*DH11+Z
                    DY(I)=-W+DH22*Z
   40               CONTINUE
               GO TO 140
   50          CONTINUE
               DH11=DPARAM(2)
               DH12=DPARAM(4)
               DH21=DPARAM(3)
               DH22=DPARAM(5)
                    DO 60 I = 1,NSTEPS,INCX
                    W=DX(I)
                    Z=DY(I)
                    DX(I)=W*DH11+Z*DH12
                    DY(I)=W*DH21+Z*DH22
   60               CONTINUE
               GO TO 140
   70     CONTINUE
          KX=1
          KY=1
          IF (INCX .LT. 0) KX = 1+(1-N)*INCX
          IF (INCY .LT. 0) KY = 1+(1-N)*INCY
C
          IF (DFLAG) 120,80,100
   80     CONTINUE
          DH12=DPARAM(4)
          DH21=DPARAM(3)
               DO 90 I = 1,N
               W=DX(KX)
               Z=DY(KY)
               DX(KX)=W+Z*DH12
               DY(KY)=W*DH21+Z
               KX=KX+INCX
               KY=KY+INCY
   90          CONTINUE
          GO TO 140
  100     CONTINUE
          DH11=DPARAM(2)
          DH22=DPARAM(5)
               DO 110 I = 1,N
               W=DX(KX)
               Z=DY(KY)
               DX(KX)=W*DH11+Z
               DY(KY)=-W+DH22*Z
               KX=KX+INCX
               KY=KY+INCY
  110          CONTINUE
          GO TO 140
  120     CONTINUE
          DH11=DPARAM(2)
          DH12=DPARAM(4)
          DH21=DPARAM(3)
          DH22=DPARAM(5)
               DO 130 I = 1,N
               W=DX(KX)
               Z=DY(KY)
               DX(KX)=W*DH11+Z*DH12
               DY(KY)=W*DH21+Z*DH22
               KX=KX+INCX
               KY=KY+INCY
  130          CONTINUE
  140     CONTINUE
          RETURN
      END
*DECK DROTMG
      SUBROUTINE DROTMG (DD1, DD2, DX1, DY1, DPARAM)
C***BEGIN PROLOGUE  DROTMG
C***PURPOSE  Construct a modified Givens transformation.
C***LIBRARY   SLATEC (BLAS)
C***CATEGORY  D1B10
C***TYPE      DOUBLE PRECISION (SROTMG-S, DROTMG-D)
C***KEYWORDS  BLAS, LINEAR ALGEBRA, MODIFIED GIVENS ROTATION, VECTOR
C***AUTHOR  Lawson, C. L., (JPL)
C           Hanson, R. J., (SNLA)
C           Kincaid, D. R., (U. of Texas)
C           Krogh, F. T., (JPL)
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C      DD1  double precision scalar
C      DD2  double precision scalar
C      DX1  double precision scalar
C      DX2  double precision scalar
C   DPARAM  D.P. 5-vector. DPARAM(1)=DFLAG defined below.
C           Locations 2-5 contain the rotation matrix.
C
C     --Output--
C      DD1  changed to represent the effect of the transformation
C      DD2  changed to represent the effect of the transformation
C      DX1  changed to represent the effect of the transformation
C      DX2  unchanged
C
C     Construct the modified Givens transformation matrix H which zeros
C     the second component of the 2-vector  (SQRT(DD1)*DX1,SQRT(DD2)*
C     DY2)**T.
C     With DPARAM(1)=DFLAG, H has one of the following forms:
C
C     DFLAG=-1.D0     DFLAG=0.D0        DFLAG=1.D0     DFLAG=-2.D0
C
C       (DH11  DH12)    (1.D0  DH12)    (DH11  1.D0)    (1.D0  0.D0)
C     H=(          )    (          )    (          )    (          )
C       (DH21  DH22),   (DH21  1.D0),   (-1.D0 DH22),   (0.D0  1.D0).
C
C     Locations 2-5 of DPARAM contain DH11, DH21, DH12, and DH22,
C     respectively.  (Values of 1.D0, -1.D0, or 0.D0 implied by the
C     value of DPARAM(1) are not stored in DPARAM.)
C
C***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
C                 Krogh, Basic linear algebra subprograms for Fortran
C                 usage, Algorithm No. 539, Transactions on Mathematical
C                 Software 5, 3 (September 1979), pp. 308-323.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   780301  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920316  Prologue corrected.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DROTMG
      DOUBLE PRECISION GAM, ONE, RGAMSQ, DD1, DD2, DH11, DH12, DH21,
     1                 DH22, DPARAM, DP1, DP2, DQ1, DQ2, DU, DY1, ZERO,
     2                 GAMSQ, DFLAG, DTEMP, DX1, TWO
      DIMENSION DPARAM(5)
      SAVE ZERO, ONE, TWO, GAM, GAMSQ, RGAMSQ
      DATA ZERO, ONE, TWO /0.0D0, 1.0D0, 2.0D0/
      DATA GAM, GAMSQ, RGAMSQ /4096.0D0, 16777216.D0, 5.9604645D-8/
C***FIRST EXECUTABLE STATEMENT  DROTMG
      IF (.NOT. DD1 .LT. ZERO) GO TO 10
C       GO ZERO-H-D-AND-DX1..
          GO TO 60
   10 CONTINUE
C     CASE-DD1-NONNEGATIVE
      DP2=DD2*DY1
      IF (.NOT. DP2 .EQ. ZERO) GO TO 20
          DFLAG=-TWO
          GO TO 260
C     REGULAR-CASE..
   20 CONTINUE
      DP1=DD1*DX1
      DQ2=DP2*DY1
      DQ1=DP1*DX1
C
      IF (.NOT. ABS(DQ1) .GT. ABS(DQ2)) GO TO 40
          DH21=-DY1/DX1
          DH12=DP2/DP1
C
          DU=ONE-DH12*DH21
C
          IF (.NOT. DU .LE. ZERO) GO TO 30
C         GO ZERO-H-D-AND-DX1..
               GO TO 60
   30     CONTINUE
               DFLAG=ZERO
               DD1=DD1/DU
               DD2=DD2/DU
               DX1=DX1*DU
C         GO SCALE-CHECK..
               GO TO 100
   40 CONTINUE
          IF (.NOT. DQ2 .LT. ZERO) GO TO 50
C         GO ZERO-H-D-AND-DX1..
               GO TO 60
   50     CONTINUE
               DFLAG=ONE
               DH11=DP1/DP2
               DH22=DX1/DY1
               DU=ONE+DH11*DH22
               DTEMP=DD2/DU
               DD2=DD1/DU
               DD1=DTEMP
               DX1=DY1*DU
C         GO SCALE-CHECK
               GO TO 100
C     PROCEDURE..ZERO-H-D-AND-DX1..
   60 CONTINUE
          DFLAG=-ONE
          DH11=ZERO
          DH12=ZERO
          DH21=ZERO
          DH22=ZERO
C
          DD1=ZERO
          DD2=ZERO
          DX1=ZERO
C         RETURN..
          GO TO 220
C     PROCEDURE..FIX-H..
   70 CONTINUE
      IF (.NOT. DFLAG .GE. ZERO) GO TO 90
C
          IF (.NOT. DFLAG .EQ. ZERO) GO TO 80
          DH11=ONE
          DH22=ONE
          DFLAG=-ONE
          GO TO 90
   80     CONTINUE
          DH21=-ONE
          DH12=ONE
          DFLAG=-ONE
   90 CONTINUE
      GO TO IGO,(120,150,180,210)
C     PROCEDURE..SCALE-CHECK
  100 CONTINUE
  110     CONTINUE
          IF (.NOT. DD1 .LE. RGAMSQ) GO TO 130
               IF (DD1 .EQ. ZERO) GO TO 160
               ASSIGN 120 TO IGO
C              FIX-H..
               GO TO 70
  120          CONTINUE
               DD1=DD1*GAM**2
               DX1=DX1/GAM
               DH11=DH11/GAM
               DH12=DH12/GAM
          GO TO 110
  130 CONTINUE
  140     CONTINUE
          IF (.NOT. DD1 .GE. GAMSQ) GO TO 160
               ASSIGN 150 TO IGO
C              FIX-H..
               GO TO 70
  150          CONTINUE
               DD1=DD1/GAM**2
               DX1=DX1*GAM
               DH11=DH11*GAM
               DH12=DH12*GAM
          GO TO 140
  160 CONTINUE
  170     CONTINUE
          IF (.NOT. ABS(DD2) .LE. RGAMSQ) GO TO 190
               IF (DD2 .EQ. ZERO) GO TO 220
               ASSIGN 180 TO IGO
C              FIX-H..
               GO TO 70
  180          CONTINUE
               DD2=DD2*GAM**2
               DH21=DH21/GAM
               DH22=DH22/GAM
          GO TO 170
  190 CONTINUE
  200     CONTINUE
          IF (.NOT. ABS(DD2) .GE. GAMSQ) GO TO 220
               ASSIGN 210 TO IGO
C              FIX-H..
               GO TO 70
  210          CONTINUE
               DD2=DD2/GAM**2
               DH21=DH21*GAM
               DH22=DH22*GAM
          GO TO 200
  220 CONTINUE
          IF (DFLAG) 250,230,240
  230     CONTINUE
               DPARAM(3)=DH21
               DPARAM(4)=DH12
               GO TO 260
  240     CONTINUE
               DPARAM(2)=DH11
               DPARAM(5)=DH22
               GO TO 260
  250     CONTINUE
               DPARAM(2)=DH11
               DPARAM(3)=DH21
               DPARAM(4)=DH12
               DPARAM(5)=DH22
  260 CONTINUE
          DPARAM(1)=DFLAG
          RETURN
      END
*DECK DSCAL
      SUBROUTINE DSCAL (N, DA, DX, INCX)
C***BEGIN PROLOGUE  DSCAL
C***PURPOSE  Multiply a vector by a constant.
C***LIBRARY   SLATEC (BLAS)
C***CATEGORY  D1A6
C***TYPE      DOUBLE PRECISION (SSCAL-S, DSCAL-D, CSCAL-C)
C***KEYWORDS  BLAS, LINEAR ALGEBRA, SCALE, VECTOR
C***AUTHOR  Lawson, C. L., (JPL)
C           Hanson, R. J., (SNLA)
C           Kincaid, D. R., (U. of Texas)
C           Krogh, F. T., (JPL)
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       DA  double precision scale factor
C       DX  double precision vector with N elements
C     INCX  storage spacing between elements of DX
C
C     --Output--
C       DX  double precision result (unchanged if N.LE.0)
C
C     Replace double precision DX by double precision DA*DX.
C     For I = 0 to N-1, replace DX(IX+I*INCX) with  DA * DX(IX+I*INCX),
C     where IX = 1 if INCX .GE. 0, else IX = 1+(1-N)*INCX.
C
C***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
C                 Krogh, Basic linear algebra subprograms for Fortran
C                 usage, Algorithm No. 539, Transactions on Mathematical
C                 Software 5, 3 (September 1979), pp. 308-323.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   791001  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   900821  Modified to correct problem with a negative increment.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DSCAL
      DOUBLE PRECISION DA, DX(*)
      INTEGER I, INCX, IX, M, MP1, N
C***FIRST EXECUTABLE STATEMENT  DSCAL
      IF (N .LE. 0) RETURN
      IF (INCX .EQ. 1) GOTO 20
C
C     Code for increment not equal to 1.
C
      IX = 1
      IF (INCX .LT. 0) IX = (-N+1)*INCX + 1
      DO 10 I = 1,N
        DX(IX) = DA*DX(IX)
        IX = IX + INCX
   10 CONTINUE
      RETURN
C
C     Code for increment equal to 1.
C
C     Clean-up loop so remaining vector length is a multiple of 5.
C
   20 M = MOD(N,5)
      IF (M .EQ. 0) GOTO 40
      DO 30 I = 1,M
        DX(I) = DA*DX(I)
   30 CONTINUE
      IF (N .LT. 5) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,5
        DX(I) = DA*DX(I)
        DX(I+1) = DA*DX(I+1)
        DX(I+2) = DA*DX(I+2)
        DX(I+3) = DA*DX(I+3)
        DX(I+4) = DA*DX(I+4)
   50 CONTINUE
      RETURN
      END
*DECK DSWAP
      SUBROUTINE DSWAP (N, DX, INCX, DY, INCY)
C***BEGIN PROLOGUE  DSWAP
C***PURPOSE  Interchange two vectors.
C***LIBRARY   SLATEC (BLAS)
C***CATEGORY  D1A5
C***TYPE      DOUBLE PRECISION (SSWAP-S, DSWAP-D, CSWAP-C, ISWAP-I)
C***KEYWORDS  BLAS, INTERCHANGE, LINEAR ALGEBRA, VECTOR
C***AUTHOR  Lawson, C. L., (JPL)
C           Hanson, R. J., (SNLA)
C           Kincaid, D. R., (U. of Texas)
C           Krogh, F. T., (JPL)
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       DX  double precision vector with N elements
C     INCX  storage spacing between elements of DX
C       DY  double precision vector with N elements
C     INCY  storage spacing between elements of DY
C
C     --Output--
C       DX  input vector DY (unchanged if N .LE. 0)
C       DY  input vector DX (unchanged if N .LE. 0)
C
C     Interchange double precision DX and double precision DY.
C     For I = 0 to N-1, interchange  DX(LX+I*INCX) and DY(LY+I*INCY),
C     where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is
C     defined in a similar way using INCY.
C
C***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
C                 Krogh, Basic linear algebra subprograms for Fortran
C                 usage, Algorithm No. 539, Transactions on Mathematical
C                 Software 5, 3 (September 1979), pp. 308-323.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   791001  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   920310  Corrected definition of LX in DESCRIPTION.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DSWAP
      DOUBLE PRECISION DX(*), DY(*), DTEMP1, DTEMP2, DTEMP3
C***FIRST EXECUTABLE STATEMENT  DSWAP
      IF (N .LE. 0) RETURN
      IF (INCX .EQ. INCY) IF (INCX-1) 5,20,60
C
C     Code for unequal or nonpositive increments.
C
    5 IX = 1
      IY = 1
      IF (INCX .LT. 0) IX = (-N+1)*INCX + 1
      IF (INCY .LT. 0) IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DTEMP1 = DX(IX)
        DX(IX) = DY(IY)
        DY(IY) = DTEMP1
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C     Code for both increments equal to 1.
C
C     Clean-up loop so remaining vector length is a multiple of 3.
C
   20 M = MOD(N,3)
      IF (M .EQ. 0) GO TO 40
      DO 30 I = 1,M
        DTEMP1 = DX(I)
        DX(I) = DY(I)
        DY(I) = DTEMP1
   30 CONTINUE
      IF (N .LT. 3) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,3
        DTEMP1 = DX(I)
        DTEMP2 = DX(I+1)
        DTEMP3 = DX(I+2)
        DX(I) = DY(I)
        DX(I+1) = DY(I+1)
        DX(I+2) = DY(I+2)
        DY(I) = DTEMP1
        DY(I+1) = DTEMP2
        DY(I+2) = DTEMP3
   50 CONTINUE
      RETURN
C
C     Code for equal, positive, non-unit increments.
C
   60 NS = N*INCX
      DO 70 I = 1,NS,INCX
        DTEMP1 = DX(I)
        DX(I) = DY(I)
        DY(I) = DTEMP1
   70 CONTINUE
      RETURN
      END
*DECK IDAMAX
      INTEGER FUNCTION IDAMAX (N, DX, INCX)
C***BEGIN PROLOGUE  IDAMAX
C***PURPOSE  Find the smallest index of that component of a vector
C            having the maximum magnitude.
C***LIBRARY   SLATEC (BLAS)
C***CATEGORY  D1A2
C***TYPE      DOUBLE PRECISION (ISAMAX-S, IDAMAX-D, ICAMAX-C)
C***KEYWORDS  BLAS, LINEAR ALGEBRA, MAXIMUM COMPONENT, VECTOR
C***AUTHOR  Lawson, C. L., (JPL)
C           Hanson, R. J., (SNLA)
C           Kincaid, D. R., (U. of Texas)
C           Krogh, F. T., (JPL)
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       DX  double precision vector with N elements
C     INCX  storage spacing between elements of DX
C
C     --Output--
C   IDAMAX  smallest index (zero if N .LE. 0)
C
C     Find smallest index of maximum magnitude of double precision DX.
C     IDAMAX = first I, I = 1 to N, to maximize ABS(DX(IX+(I-1)*INCX)),
C     where IX = 1 if INCX .GE. 0, else IX = 1+(1-N)*INCX.
C
C***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
C                 Krogh, Basic linear algebra subprograms for Fortran
C                 usage, Algorithm No. 539, Transactions on Mathematical
C                 Software 5, 3 (September 1979), pp. 308-323.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   791001  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900821  Modified to correct problem with a negative increment.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  IDAMAX
      DOUBLE PRECISION DX(*), DMAX, XMAG
      INTEGER I, INCX, IX, N
C***FIRST EXECUTABLE STATEMENT  IDAMAX
      IDAMAX = 0
      IF (N .LE. 0) RETURN
      IDAMAX = 1
      IF (N .EQ. 1) RETURN
C
      IF (INCX .EQ. 1) GOTO 20
C
C     Code for increments not equal to 1.
C
      IX = 1
      IF (INCX .LT. 0) IX = (-N+1)*INCX + 1
      DMAX = ABS(DX(IX))
      IX = IX + INCX
      DO 10 I = 2,N
        XMAG = ABS(DX(IX))
        IF (XMAG .GT. DMAX) THEN
          IDAMAX = I
          DMAX = XMAG
        ENDIF
        IX = IX + INCX
   10 CONTINUE
      RETURN
C
C     Code for increments equal to 1.
C
   20 DMAX = ABS(DX(1))
      DO 30 I = 2,N
        XMAG = ABS(DX(I))
        IF (XMAG .GT. DMAX) THEN
          IDAMAX = I
          DMAX = XMAG
        ENDIF
   30 CONTINUE
      RETURN
      END


PROGRAM SAMPLE_MAIN_P
! Driver code that reads a set P of data points from a file and computes
! the containing simplices and interpolation weights for a set Q of
! user-specified interpolation points using DELAUNAYSPARSEP. If response
! values are provided, the interpolant f_{DT}(q) is also computed for all
! q \in Q.
!
! Usage: ./samplep $(filepath)
!
! where $(filepath) is the relative or absolute path to the input file,
! formatted as follows.
!
! D,N,M,IR
! [Data/training points]
! [Response/function values]
! [Interpolation points]
!
! where
! D is the dimension of problem,
! N is the number of data/training points (contained in lines 2 -- N+1),
! M is the number of interpolation points (contained in lines 2N+2 -- 2N+1+M),
! IR is the dimension of the output f(x) (the corresponding f(p) for p \in P
!   are stored in lines N+2 -- 2N+1).
!
! If IR = 0, then no interpolation will be done (and the M interpolation points
! are stored in lines N+2 -- N+1+M).
!
! A sample input file with D=2, N=43, M=101, IR=1 is provided by
! sample_input2d.dat.
! A sample input file with D=4, N=432, M=432, IR=1 is provided by
! sample_input4d.dat.
!
! Last Update: March, 2020
! Primary Author: Tyler Chang
USE DELSPARSE_MOD
USE OMP_LIB
IMPLICIT NONE

! Declare arguments and local data.
! Problem dimensions.
INTEGER :: D ! Problem dimension.
INTEGER :: N ! Number of data points.
INTEGER :: M ! Number of interpolation points.
INTEGER :: IR ! Response values (i.e., the dimension of the output).
! DELAUNAYSPARSE argument arrays.
REAL(KIND=R8), ALLOCATABLE :: PTS(:,:) ! The input data points.
REAL(KIND=R8), ALLOCATABLE :: Q(:,:) ! The interpolation points.
REAL(KIND=R8), ALLOCATABLE :: WEIGHTS(:,:) ! The interpolation weights.
INTEGER, ALLOCATABLE :: SIMPS(:,:) ! The indices of the simplex vertices.
INTEGER, ALLOCATABLE :: IERR(:) ! Array of integer error flags.
! Optional argument arrays.
REAL(KIND=R8), ALLOCATABLE :: INTERP_IN(:,:) ! Response value array.
REAL(KIND=R8), ALLOCATABLE :: INTERP_OUT(:,:) ! Output array for f_DT(q).
REAL(KIND=R8), ALLOCATABLE :: RNORM(:) ! Array of extrapolation residuals.
! Local variables.
INTEGER :: I ! Loop index/temp value.
REAL(KIND=R8) :: TICK ! The current clock time/total walltime.
CHARACTER(LEN=80) :: FILEPATH ! Input filepath.

! Open the file path $(filepath), and get the metadata from the
! first line (D, N, M, and IR).
CALL GET_COMMAND_ARGUMENT(1, FILEPATH)
OPEN(1, FILE=TRIM(FILEPATH))
READ(1, *) D, N, M, IR
IF(D .LE. 0 .OR. N .LE. 0 .OR. M .LE. 0) THEN
   WRITE(*,*) "Illegal input dimensions in input file, line 1."; STOP
END IF

! Allocate all necessarry arrays.
ALLOCATE(PTS(D,N), WEIGHTS(D+1,M), Q(D,M), SIMPS(D+1,M), IERR(M), &
  & RNORM(M), STAT=I)
IF(I .NE. 0) THEN
   WRITE(*,*) "Memory allocation error."; STOP
END IF

! Read the input data/training points into PTS.
DO I = 1, N
   READ(1, *) PTS(:, I)
END DO
! Check if there are any response values.
IF (IR > 0) THEN
   ! If so, allocate INTERP_IN and INTERP_OUT.
   ALLOCATE(INTERP_IN(IR,N), INTERP_OUT(IR,M), STAT=I)
   IF(I .NE. 0) THEN
      WRITE(*,*) "Memory allocation error."; STOP
   END IF
   ! Then, read the response values into INTERP_IN.
   DO I = 1, N
      READ(1, *) INTERP_IN(:,I)
   END DO
END IF
! Read the interpolation points into Q.
DO I = 1, M
   READ(1, *) Q(:, I)
END DO
CLOSE(1)

! Compute the interpolation results and time.
! If response values are provided, compute the outputs f_{DT}(q).
IF (IR > 0) THEN
   TICK = OMP_GET_WTIME()
   ! Call DELAUNAYSPARSEP with INTERP_IN and INTERP_OUT.
   CALL DELAUNAYSPARSEP(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, &
     ! Optional argument list.
     & INTERP_IN=INTERP_IN, INTERP_OUT=INTERP_OUT,             &
     & EPS=SQRT(EPSILON(0.0_R8)), EXTRAP=0.1_R8, RNORM=RNORM,  &
     & IBUDGET = 50000, CHAIN=.FALSE., EXACT=.TRUE., PMODE=1)
   TICK = OMP_GET_WTIME() - TICK
! Otherwise, just compute the simplices and weights.
ELSE
   TICK = OMP_GET_WTIME()
   ! Call DELAUNAYSPARSEP without INTERP_IN and INTERP_OUT.
   CALL DELAUNAYSPARSEP(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, &
     ! Optional argument list. Note that INTERP_IN and INTERP_OUT
     ! have been excluded.
     & EPS=SQRT(EPSILON(0.0_R8)), EXTRAP=0.1_R8, RNORM=RNORM,  &
     & IBUDGET = 50000, CHAIN=.FALSE., EXACT=.TRUE., PMODE=1)
   TICK = OMP_GET_WTIME() - TICK

END IF

! Display the results of the interpolation.
DO I = 1, M
   IF(IERR(I) .EQ. 0) THEN
      WRITE(*,10) 'Interpolation point: ', Q(:,I)
      WRITE(*,11) 'Simplex: ', SIMPS(:,I)
      WRITE(*,10) 'Weights: ', WEIGHTS(:,I)
      IF (IR > 0) THEN
         WRITE(*,12) 'f(x) = ', INTERP_OUT(:,I)
      END IF
   ELSE IF(IERR(I) .EQ. 1) THEN
      WRITE(*,10) 'Extrapolation point: ', Q(:,I)
      WRITE(*,11) 'Simplex: ', SIMPS(:,I)
      WRITE(*,10) 'Weights: ', WEIGHTS(:,I)
      IF (IR > 0) THEN
         WRITE(*,12) 'f(x) = ', INTERP_OUT(:,I)
      END IF
      WRITE(*,13) 'Residual: ', RNORM(I)
   ELSE IF(IERR(I) .EQ. 2) THEN
      WRITE(*,10) 'Extrapolation point: ', Q(:,I)
      WRITE(*,13) 'Residual: ', RNORM(I)
   ELSE
      WRITE(*,14) 'Error at point ', I, '. IERR(I) = ', IERR(I)
   END IF
END DO
! Print the timing data.
WRITE(*,15) M, ' points interpolated in ', TICK, ' seconds.'
10 FORMAT(1X,A,/,(1X,5ES15.7))
11 FORMAT(1X,A,/,(10I7))
12 FORMAT(1X,A,4ES15.7,/,(1X,5ES15.7))
13 FORMAT(1X,A,ES16.8)
14 FORMAT(1X,A,I7,A,I2)
15 FORMAT(/,I7,A,ES16.8,A,/)

END PROGRAM SAMPLE_MAIN_P


module FuncContainer
  implicit none
contains

  function func1(x)
    real :: func1
    real, intent(in) :: x

    func1 = x**2.0
  end function func1

  function func2(x)
    real :: func2
    real, intent(in) :: x

    func2 = x**2.05
  end function func2

end module FuncContainer

program FuncArg
  use FuncContainer
  implicit none

  print *, "Func1"
  call asubroutine(func1)

  print *, "Func2"
  call asubroutine(func2)

contains

  subroutine asubroutine(f)
    ! the following interface is redundant: can be omitted
    interface
       function f(x)
         real, intent(in) :: x
         real :: f
       end function f
    end interface
    real :: px

    px = 0.0
    do while( px < 10.0 )
       print *, px, f(px)
       px = px + 1.0
    end do
  end subroutine asubroutine

end program FuncArg


!
! Copyright (c) 2017, NVIDIA CORPORATION.  All rights reserved.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.
!
! Problem when a function call is used as a loop upper bound,
! and the loop contains code that will create an allocatable
! temp, and the allocate of the temp gets floated out of the loop
! the function call is replicated three times: once as the loop limit,
! once as the zero-trip test for the allocate, and again for the deallocate
! problem manifested itself as far back as 6.1 pgf90, maybe earlier

module mmm1
 type dt
  integer :: pos(3)
 end type

 integer :: ii = 0
contains

 integer function n1(self)
  type(dt),dimension(:) :: self
  ii = ii + 1
  n1 = size(self) - ii
 end function

 subroutine rotate1(self,matrix)
  type(dt),dimension(:) :: self
  integer,intent(in),dimension(3,3)::matrix
  integer:: n
  do n = 1,n1(self)
   self(n)%pos = matmul(matrix,self(n)%pos)
  enddo
 end subroutine

end module

program p
 use mmm1
 type(dt),dimension(10) :: self
 integer,dimension(3,3) :: matrix
 integer::result(30)
 integer::expect(30)
 data expect/ 1,3,2,1,3,2,1,3,2,1, &
              2,1,3,2,1,3,2,1,3,2, &
              3,2,1,3,2,1,3,2,1,3 /

 do i = 1,10
  self(i)%pos(1) = 1
  self(i)%pos(2) = 2
  self(i)%pos(3) = 3
 enddo

 matrix(1,:) = (/ 0, 1, 0 /)
 matrix(2,:) = (/ 0, 0, 1 /)
 matrix(3,:) = (/ 1, 0, 0 /)

 do i = 1,10
  call rotate1( self, matrix )
 enddo
 result( 1:10) = self(:)%pos(1)
 result(11:20) = self(:)%pos(2)
 result(21:30) = self(:)%pos(3)
 call check(result,expect,30)
end program


C   File: array-loop_01.f
C   This test is an example of having an array under the nested
C   loop and initialize to zero.
C
C   The code was sampled from SIR-Gillespie.f
      program main
      implicit none

      integer, parameter :: Tmax = 100
      integer i, j

      double precision, dimension(0:Tmax) :: MeanS, MeanI, MeanR
      double precision, dimension(0:Tmax) :: VarS, VarI, VarR
      integer, dimension(0:Tmax) :: samples

      do j = 0, Tmax
          do i = 0, Tmax    ! Initialize the mean and variance arrays
             MeanS(i) = 0
             MeanI(i) = 0.0
             MeanR(i) = 0.0

             VarS(i) = 0.0
             VarI(i) = 0.0
             VarR(i) = 0.0

             samples(i) = i
          end do
      end do

      end program main


submodule(forlab) forlab_arange
    use forlab_kinds
    implicit none

contains
    module procedure arange_int8
        integer(int8) :: i
        if (first <= last) then
            arange_int8 = [(i, i=first, last)]
        else
            arange_int8 = [(i, i=first, last, -1)]
        end if
        return
    end procedure
    module procedure arange_int16
        integer(int16) :: i
        if (first <= last) then
            arange_int16 = [(i, i=first, last)]
        else
            arange_int16 = [(i, i=first, last, -1)]
        end if
        return
    end procedure
    module procedure arange_int32
        integer(int32) :: i
        if (first <= last) then
            arange_int32 = [(i, i=first, last)]
        else
            arange_int32 = [(i, i=first, last, -1)]
        end if
        return
    end procedure
    module procedure arange_int64
        integer(int64) :: i
        if (first <= last) then
            arange_int64 = [(i, i=first, last)]
        else
            arange_int64 = [(i, i=first, last, -1)]
        end if
        return
    end procedure
end submodule


SUBROUTINE Preprocess
   USE PrecTypes
   USE GlobalData
   IMPLICIT NONE

   ! -------------------------------------------------------------------------
   ! NAME:   Preprocess
   ! PARENT: Feritas
   ! STATUS: Current
   ! OWNER:  Toshiro Matsumoto
   ! TEXT:   Set flags, calculate number of knowns and unknowns, allocate arrays.
   ! REVISION DATE: 16-Jul-2009
   ! -------------------------------------------------------------------------

   INTEGER :: i,j,k,l

   ! Linear heat conduction problem:
   ! When the temperature is known, the flag is set to 1, otherwise set to 0.
   !
   ! Linear elastostatic and thermo-elastostatic problem:
   ! When the displacement is each direction is known, the flag in that direction
   ! is set to 1, otherwise set to 0.
   !
   IF (pcode==1) THEN

      tflag = 0   ! The flag to identify when the temperature are known initialized.
      T = 0.0     ! Nodal temperatures are initialized.
      bNodeFlag=0 ! The flag which is set to 1 when the node is on the boundary and 0 when in the domain.
                  ! Initally all the flags are set to zero.
      DO i=1,ns
         DO j=1,Stype(i)   ! Repeat for the number of nodes composing each element

            IF(bNodeFlag(Sid(i,j)) == 0) THEN
               bNodeFlag(Sid(i,j)) = 1
            END IF

            IF (bccode(i,j) == uKNOWN) THEN   ! The case when the temperature is known
               tflag( Sid(i,j)) = 1           ! The flag is set so that the temperature is known
               T( Sid(i,j) ) = bcval(i,j)     ! The boundary condition value is set as the nodal temperature
            END IF

         END DO
      END DO

! For debugging ------------------
!DO i=1,node
!   WRITE(*,'(I2,2x,I1,2x,E15.8)') i, tflag(i), T(i)
!END DO
! ----------------------------

   ELSE IF (pcode==2 .OR. pcode==3) THEN

      uflag = 0   ! The flag to identify when the displacement component is known is initialized.
      u = 0.0     ! Nodal displacements are initialized.
      bNodeFlag=0 ! The flag which is set to 1 when the node is on the boundary and 0 when in the domain.
                  ! Initally all the flags are set to zero.

      DO i=1,ns
         DO j=1,Stype(i)   ! Repeat for the number of nodes composing each element

            IF(bNodeFlag(Sid(i,j)) == 0) THEN

               bNodeFlag(Sid(i,j)) = 1

            END IF

            DO k=1,dir     ! Repeat for x, y, (and z)

               IF (bcc(i,j,k) == uKNOWN) THEN     ! The case when the displacement is known

                  uflag( Sid(i,j), k ) = 1        ! The flag is set so that the displacement is known
                  u( Sid(i,j), k ) = bcv(i,j,k)   ! The boundary condition value is set as the nodal displacement

               END IF

            END DO

         END DO
      END DO

! For debugging ------------------
!DO i=1,node
!   WRITE(*,'(I2,2x,I1,x,I1,2x,E15.8,x,E15.8)') i, (uflag(i,j),j=1,dir), (u(i,j),j=1,dir)
!END DO
! ----------------------------

   END IF

   N_unknowns = 0    ! Total number of unknowns
   N_knowns = 0      ! Total number of knowns (set as a negative integer number)

   ! Steady-state heat conduction problem
   IF (pcode==1) THEN

      ! In 'ptable(i)', the temperature of node 'i' is saved
      DO i=1,node

         IF (tflag(i) == 0) THEN

            N_unknowns = N_unknowns + 1
            ptable(i) = N_unknowns

         ELSE IF (tflag(i) == 1) THEN

            N_knowns = N_knowns - 1
            ptable(i) = N_knowns

         END IF

      END DO

! For debugging ------------------
!write(*,'(a,I5)') 'Number of unknowns =',N_unknowns
!DO i=1,node
!write(*,'("ptable ",I2,x,I2)') i,ptable(i)
!END DO
! ----------------------------

   ! Linear elastostatic and thermo-elastostatic problem
   ELSE IF (pcode==2 .OR. pcode==3) THEN

      ! In 'table(i,j)', the displacement in 'j' direction of the node 'i' is saved
      DO i=1,node
         DO j=1,dir

            IF (uflag(i,j) == 0) THEN

               N_unknowns = N_unknowns + 1
               table(i,j) = N_unknowns

            ELSE IF (uflag(i,j) == 1) THEN

               N_knowns = N_knowns - 1
               table(i,j) = N_knowns

            END IF

         END DO
      END DO

! For debugging ------------------
!      write(*,'(a,I5)') 'Number of unknowns =',N_unknowns
!      DO i=1,node
!         DO j=1,dir
!            write(*,'("table ",I2,x,I2,3x,i3)') i,j,table(i,j)
!         END DO
!      END DO
! ----------------------------

   END IF

   ! Allocation of arrays of stiffness matrix and right-hand-side equivalent shear force vector
   ALLOCATE(Km(N_unknowns,N_unknowns), Fv(N_unknowns))

   ! Allocation of arrays of stiffness matrix for calculating unknown nodal fluxes
   ! and unknown nodal reaction forces, and their vector themselves
   IF(N_knowns<0) THEN
      ALLOCATE( Kmm(-N_knowns,dir*node), Fvv(-N_knowns) )
   ELSE
      ALLOCATE( Kmm(3,3), Fvv(3) )
   END IF

   RETURN
END SUBROUTINE Preprocess


c>>   1990-02-09  DRINSORT  Snyder  Initial code.
c
c     Test driver for INSORT.
c
c     Construct an array of 1000 random numbers using SRANUA.
c     Sort it using INSORT.
c     Check whether it is in order.
c
      logical OK
      integer COMPAR,L(1:1000),L1,LS,NCOMP
      external COMPAR
      real PREV,R(1:1000)
      common /RCOM/ NCOMP,R
c
c     Generate 1000 random numbers
      call sranua (r, 1000)
c     Sort them using INSORT.
      ncomp=0
      call insort (compar,1000,l,l1)
      ls = l1
c     Check the order.
      ok=.TRUE.
      prev=-1.0
10    if (l1.ne.0) then
         if (r(l1).lt.prev) ok=.FALSE.
         prev=r(l1)
         l1=l(l1)
         go to 10
      end if
c     Convert l to a permutation vector.
      call pvec (l,ls)
c     Check the order again.
      do 20 ls = 2, 1000
         if (r(l(ls)) .lt. r(l(ls-1))) ok=.FALSE.
20    continue
c     Print the results.
      if (ok) then
         print '('' INSORT succeeded using'',i6,'' compares'')', ncomp
      else
         print *,'INSORT failed'
      end if
c
      end
      integer function COMPAR(I,J)
c
c     Determine the relative order of R(I) and R(J), where R is in
c     the common block /RCOM/.  Return -1 if R(I) should preceed R(J)
c     in the sorted order, +1 if R(I) should follow R(J), and 0
c     otherwise.
c
      integer I,J, NCOMP
      real R(1:1000)
      common /RCOM/ NCOMP,R
      ncomp=ncomp+1
      if (R(I)-R(J)) 10,20,30
10    compar=-1
      return
20    compar=0
      return
30    compar=+1
      return
c
      end


! { dg-do run }
!
! CO_SUM/CO_MIN/CO_MAX
!
program test
  implicit none
  intrinsic co_max
  intrinsic co_min
  intrinsic co_sum
  integer :: val(3), tmp_val(3)
  integer :: vec(3)
  vec = [2,3,1]
  if (this_image() == 1) then
    val(1) = 42
  else
    val(1) = -99
  endif
  val(2) = this_image()
  if (this_image() == num_images()) then
    val(3) = -55
  else
    val(3) = 101
  endif
  tmp_val = val
  call test_min
  val = tmp_val
  call test_max
  val = tmp_val
  call test_sum
contains
  subroutine test_max
    integer :: tmp
    call co_max (val(::2))
    if (num_images() > 1) then
      if (any (val /= [42, this_image(), 101])) STOP 1
    else
      if (any (val /= [42, this_image(), -55])) STOP 2
    endif

    val = tmp_val
    call co_max (val(:))
    if (num_images() > 1) then
      if (any (val /= [42, num_images(), 101])) STOP 3
    else
      if (any (val /= [42, num_images(), -55])) STOP 4
    endif
  end subroutine test_max

  subroutine test_min
    call co_min (val, result_image=num_images())
    if (this_image() == num_images()) then
      !write(*,*) "Minimal value", val
      if (num_images() > 1) then
        if (any (val /= [-99, 1, -55])) STOP 5
      else
        if (any (val /= [42, 1, -55])) STOP 6
      endif
    else
      if (any (val /= tmp_val)) STOP 7
    endif
  end subroutine test_min

  subroutine test_sum
    integer :: n
    n = 88
    call co_sum (val, result_image=1, stat=n)
    if (n /= 0) STOP 8
    if (this_image() == 1) then
      n = num_images()
      !write(*,*) "The sum is ", val
      if (any (val /= [42 + (n-1)*(-99), (n**2 + n)/2, -55+(n-1)*101])) STOP 9
    else
      if (any (val /= tmp_val)) STOP 10
    end if
  end subroutine test_sum
end program test