MODULE shared_data
IMPLICIT NONE
SAVE

  INTEGER, PARAMETER :: num_vals = 5
  REAL, DIMENSION(num_vals) :: values
END MODULE

PROGRAM test_module
USE shared_data
IMPLICIT NONE

  REAL, PARAMETER :: PI = 3.141592
  values = PI * [1., 2., 3., 4., 5.]

  CALL sub1
END PROGRAM test_module

SUBROUTINE sub1
USE shared_data
IMPLICIT NONE
  WRITE(*, *) values
END SUBROUTINE sub1


#
# test yield
#

print("Testing yield...")
errors = 0

loop = fn (n: int)
    for i in 1 to n
        yield i

pairs = fn (n: int)
    for i in 1 to n {
        # print ("pairs i:{i}\n")
        yield (yield i) ^ 2
    }

squares = fn (n: int)
    for i in 1 to n
        yield [ i, i ^ 2 ]

try assert [ loop(5) ] == [ 1, 2, 3, 4, 5 ] rescue errors += 1
assert [ pairs(4) ] == [1, 1, 2, 4, 3, 9, 4, 16]
try assert [ squares(4) ] == [ [1, 1], [2, 4], [3, 9], [4, 16] ] rescue errors += 1

# test infinite generator
integers = fn () {
    i = 0
    while true
        yield i += 1
}

scan = fn (n: int) {
    retval = []
    for i in integers() {
        retval += [ i ]
        if i >= n return retval
    }
}

try assert scan(100) == 1 to 100 rescue errors += 1

print(if errors "Some tests failed ({errors}) errors\n" else "passed!\n")


*DECK CSPFA
      SUBROUTINE CSPFA (AP, N, KPVT, INFO)
C***BEGIN PROLOGUE  CSPFA
C***PURPOSE  Factor a complex symmetric matrix stored in packed form by
C            elimination with symmetric pivoting.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2C1
C***TYPE      COMPLEX (SSPFA-S, DSPFA-D, CHPFA-C, CSPFA-C)
C***KEYWORDS  LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, PACKED,
C             SYMMETRIC
C***AUTHOR  Bunch, J., (UCSD)
C***DESCRIPTION
C
C     CSPFA factors a complex symmetric matrix stored in
C     packed form by elimination with symmetric pivoting.
C
C     To solve  A*X = B , follow CSPFA by CSPSL.
C     To compute  INVERSE(A)*C , follow CSPFA by CSPSL.
C     To compute  DETERMINANT(A) , follow CSPFA by CSPDI.
C     To compute  INVERSE(A) , follow CSPFA by CSPDI.
C
C     On Entry
C
C        AP      COMPLEX (N*(N+1)/2)
C                the packed form of a symmetric matrix  A .  The
C                columns of the upper triangle are stored sequentially
C                in a one-dimensional array of length  N*(N+1)/2 .
C                See comments below for details.
C
C        N       INTEGER
C                the order of the matrix  A .
C
C     On Return
C
C        AP      a block diagonal matrix and the multipliers which
C                were used to obtain it stored in packed form.
C                The factorization can be written  A = U*D*TRANS(U)
C                where  U  is a product of permutation and unit
C                upper triangular matrices , TRANS(U) is the
C                transpose of  U , and  D  is block diagonal
C                with 1 by 1 and 2 by 2 blocks.
C
C        KVPT    INTEGER(N)
C                an integer vector of pivot indices.
C
C        INFO    INTEGER
C                = 0  normal value.
C                = K  if the K-th pivot block is singular.  This is
C                     not an error condition for this subroutine,
C                     but it does indicate that CSPSL or CSPDI may
C                     divide by zero if called.
C
C     Packed Storage
C
C          The following program segment will pack the upper
C          triangle of a symmetric matrix.
C
C                K = 0
C                DO 20 J = 1, N
C                   DO 10 I = 1, J
C                      K = K + 1
C                      AP(K)  = A(I,J)
C             10    CONTINUE
C             20 CONTINUE
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  CAXPY, CSWAP, ICAMAX
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891107  Corrected category and modified routine equivalence
C           list.  (WRB)
C   891107  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  CSPFA
      INTEGER N,KPVT(*),INFO
      COMPLEX AP(*)
C
      COMPLEX AK,AKM1,BK,BKM1,DENOM,MULK,MULKM1,T
      REAL ABSAKK,ALPHA,COLMAX,ROWMAX
      INTEGER ICAMAX,IJ,IK,IKM1,IM,IMAX,IMAXP1,IMIM,IMJ,IMK
      INTEGER J,JJ,JK,JKM1,JMAX,JMIM,K,KK,KM1,KM1K,KM1KM1,KM2,KSTEP
      LOGICAL SWAP
      COMPLEX ZDUM
      REAL CABS1
      CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
C***FIRST EXECUTABLE STATEMENT  CSPFA
C
C     INITIALIZE
C
C     ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE.
C
      ALPHA = (1.0E0 + SQRT(17.0E0))/8.0E0
C
      INFO = 0
C
C     MAIN LOOP ON K, WHICH GOES FROM N TO 1.
C
      K = N
      IK = (N*(N - 1))/2
   10 CONTINUE
C
C        LEAVE THE LOOP IF K=0 OR K=1.
C
         IF (K .EQ. 0) GO TO 200
         IF (K .GT. 1) GO TO 20
            KPVT(1) = 1
            IF (CABS1(AP(1)) .EQ. 0.0E0) INFO = 1
            GO TO 200
   20    CONTINUE
C
C        THIS SECTION OF CODE DETERMINES THE KIND OF
C        ELIMINATION TO BE PERFORMED.  WHEN IT IS COMPLETED,
C        KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND
C        SWAP WILL BE SET TO .TRUE. IF AN INTERCHANGE IS
C        REQUIRED.
C
         KM1 = K - 1
         KK = IK + K
         ABSAKK = CABS1(AP(KK))
C
C        DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN
C        COLUMN K.
C
         IMAX = ICAMAX(K-1,AP(IK+1),1)
         IMK = IK + IMAX
         COLMAX = CABS1(AP(IMK))
         IF (ABSAKK .LT. ALPHA*COLMAX) GO TO 30
            KSTEP = 1
            SWAP = .FALSE.
         GO TO 90
   30    CONTINUE
C
C           DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN
C           ROW IMAX.
C
            ROWMAX = 0.0E0
            IMAXP1 = IMAX + 1
            IM = IMAX*(IMAX - 1)/2
            IMJ = IM + 2*IMAX
            DO 40 J = IMAXP1, K
               ROWMAX = MAX(ROWMAX,CABS1(AP(IMJ)))
               IMJ = IMJ + J
   40       CONTINUE
            IF (IMAX .EQ. 1) GO TO 50
               JMAX = ICAMAX(IMAX-1,AP(IM+1),1)
               JMIM = JMAX + IM
               ROWMAX = MAX(ROWMAX,CABS1(AP(JMIM)))
   50       CONTINUE
            IMIM = IMAX + IM
            IF (CABS1(AP(IMIM)) .LT. ALPHA*ROWMAX) GO TO 60
               KSTEP = 1
               SWAP = .TRUE.
            GO TO 80
   60       CONTINUE
            IF (ABSAKK .LT. ALPHA*COLMAX*(COLMAX/ROWMAX)) GO TO 70
               KSTEP = 1
               SWAP = .FALSE.
            GO TO 80
   70       CONTINUE
               KSTEP = 2
               SWAP = IMAX .NE. KM1
   80       CONTINUE
   90    CONTINUE
         IF (MAX(ABSAKK,COLMAX) .NE. 0.0E0) GO TO 100
C
C           COLUMN K IS ZERO.  SET INFO AND ITERATE THE LOOP.
C
            KPVT(K) = K
            INFO = K
         GO TO 190
  100    CONTINUE
         IF (KSTEP .EQ. 2) GO TO 140
C
C           1 X 1 PIVOT BLOCK.
C
            IF (.NOT.SWAP) GO TO 120
C
C              PERFORM AN INTERCHANGE.
C
               CALL CSWAP(IMAX,AP(IM+1),1,AP(IK+1),1)
               IMJ = IK + IMAX
               DO 110 JJ = IMAX, K
                  J = K + IMAX - JJ
                  JK = IK + J
                  T = AP(JK)
                  AP(JK) = AP(IMJ)
                  AP(IMJ) = T
                  IMJ = IMJ - (J - 1)
  110          CONTINUE
  120       CONTINUE
C
C           PERFORM THE ELIMINATION.
C
            IJ = IK - (K - 1)
            DO 130 JJ = 1, KM1
               J = K - JJ
               JK = IK + J
               MULK = -AP(JK)/AP(KK)
               T = MULK
               CALL CAXPY(J,T,AP(IK+1),1,AP(IJ+1),1)
               AP(JK) = MULK
               IJ = IJ - (J - 1)
  130       CONTINUE
C
C           SET THE PIVOT ARRAY.
C
            KPVT(K) = K
            IF (SWAP) KPVT(K) = IMAX
         GO TO 190
  140    CONTINUE
C
C           2 X 2 PIVOT BLOCK.
C
            KM1K = IK + K - 1
            IKM1 = IK - (K - 1)
            IF (.NOT.SWAP) GO TO 160
C
C              PERFORM AN INTERCHANGE.
C
               CALL CSWAP(IMAX,AP(IM+1),1,AP(IKM1+1),1)
               IMJ = IKM1 + IMAX
               DO 150 JJ = IMAX, KM1
                  J = KM1 + IMAX - JJ
                  JKM1 = IKM1 + J
                  T = AP(JKM1)
                  AP(JKM1) = AP(IMJ)
                  AP(IMJ) = T
                  IMJ = IMJ - (J - 1)
  150          CONTINUE
               T = AP(KM1K)
               AP(KM1K) = AP(IMK)
               AP(IMK) = T
  160       CONTINUE
C
C           PERFORM THE ELIMINATION.
C
            KM2 = K - 2
            IF (KM2 .EQ. 0) GO TO 180
               AK = AP(KK)/AP(KM1K)
               KM1KM1 = IKM1 + K - 1
               AKM1 = AP(KM1KM1)/AP(KM1K)
               DENOM = 1.0E0 - AK*AKM1
               IJ = IK - (K - 1) - (K - 2)
               DO 170 JJ = 1, KM2
                  J = KM1 - JJ
                  JK = IK + J
                  BK = AP(JK)/AP(KM1K)
                  JKM1 = IKM1 + J
                  BKM1 = AP(JKM1)/AP(KM1K)
                  MULK = (AKM1*BK - BKM1)/DENOM
                  MULKM1 = (AK*BKM1 - BK)/DENOM
                  T = MULK
                  CALL CAXPY(J,T,AP(IK+1),1,AP(IJ+1),1)
                  T = MULKM1
                  CALL CAXPY(J,T,AP(IKM1+1),1,AP(IJ+1),1)
                  AP(JK) = MULK
                  AP(JKM1) = MULKM1
                  IJ = IJ - (J - 1)
  170          CONTINUE
  180       CONTINUE
C
C           SET THE PIVOT ARRAY.
C
            KPVT(K) = 1 - K
            IF (SWAP) KPVT(K) = -IMAX
            KPVT(K-1) = KPVT(K)
  190    CONTINUE
         IK = IK - (K - 1)
         IF (KSTEP .EQ. 2) IK = IK - (K - 2)
         K = K - KSTEP
      GO TO 10
  200 CONTINUE
      RETURN
      END


! { dg-do compile }
! This test executes all code paths in gfc_arith_divide
! when executed along with it's companion test
! arith_divide_no_check.f
        implicit none
        integer i,j
        real a,b
        complex c,d
        i = 10/40
        j = 10/0! { dg-error "Division by zero at" }
        a = 10.0/40.0
        b = 10.0/0.0! { dg-error "Division by zero at" }
        c = (1.0,1.0)/(10.0,40.0) !  Not division by zero
        d = (1.0,10.)/(0.0,0.0)! { dg-error "Division by zero at" }
        end


program mergesort
   use mergesort_module
   use random_module
   use dump_module
   implicit none
   ! variables and arrays
   integer, parameter :: RECSIZ = 128, NOSTR = 405995
   integer :: i, idx, n, clock
   real :: t1, t2, rnd
   character (len = 12) :: nstr
   character (len = 50) :: path
   character (len = RECSIZ) :: word
   integer, dimension(:), allocatable :: x, y
   double precision, dimension(:), allocatable :: r, s
   character (len = RECSIZ), dimension(:), allocatable :: wshuf, wsort
   ! processing
   if (command_argument_count() < 1) then
      call get_command(path)
      write (0,*) 'usage: ', trim(path), ' n'
      stop 'processing terminated'
   end if
   call get_command_argument(1, nstr)
   read (nstr,*) n
   ! integer section
   write (*,*) 'integers'
   allocate (x(n))
   allocate (y(n))
   call init_random_seed()
   x = random_integers(n)
   if (n <= 50) call dump(n, x)
   write (*,*) 'ascending'
   write (*,*) sorted(n, x, 'ASC')
   call cpu_time(t1)
   call sort(n, x, y, 'ASC')
   call cpu_time(t2)
   if (n <= 50) call dump(n, y)
   write (*,*) sorted(n, y, 'ASC')
   write (*,*) 'elapsed time = ', t2-t1, ' secs.'
   x = random_integers(n)
   if (n <= 50) call dump(n, x)
   write (*,*) 'descending'
   call cpu_time(t1)
   call sort(n, x, y, 'DESC')
   call cpu_time(t2)
   if (n <= 50) call dump(n, y)
   write (*,*) sorted(n, y, 'DESC')
   write (*,*) 'elapsed time = ', t2-t1, ' secs.'
   deallocate (x)
   deallocate (y)
   ! double precision section
   write (*,*) 'double precision'
   allocate (r(n))
   allocate (s(n))
   r = random_reals(n)
   if (n <= 50) call dump(n, r)
   write (*,*) sorted(n, r, 'ASC')
   write (*,*) 'ascending'
   call cpu_time(t1)
   call sort(n, r, s, 'ASC')
   call cpu_time(t2)
   if (n <= 50) call dump(n, s)
   write (*,*) sorted(n, s, 'ASC')
   write (*,*) 'elapsed time = ', t2-t1, ' secs.'
   r = random_reals(n)
   if (n <= 50) call dump(n, r)
   write (*,*) 'descending'
   call cpu_time(t1)
   call sort(n, r, s, 'DESC')
   call cpu_time(t2)
   if (n <= 50) call dump(n, s)
   write (*,*) sorted(n, s, 'DESC')
   write (*,*) 'elapsed time = ', t2-t1, ' secs.'
   deallocate (r)
   deallocate (s)
   ! character string section
   write (*,*) 'character strings'
   n = MIN(n, NOSTR)
   allocate (wshuf(n))
   allocate (wsort(n))
   wshuf = random_strings(n, RECSIZ, NOSTR)
   if (n <= 50) call dump(n, wshuf)
   write (*,*) sorted(n, wshuf, 'ASC')
   write (*,*) 'ascending'
   call cpu_time(t1)
   call sort(n, wshuf, wsort, 'ASC')
   call cpu_time(t2)
   if (n <= 50) call dump(n, wsort)
   write (*,*) sorted(n, wsort, 'ASC')
   write (*,*) 'elapsed time = ', t2-t1, ' secs.'
   wshuf = random_strings(n, RECSIZ, NOSTR)
   if (n <= 50) call dump(n, wshuf)
   write (*,*) 'descending'
   call cpu_time(t1)
   call sort(n, wshuf, wsort, 'DESC')
   call cpu_time(t2)
   if (n <= 50) call dump(n, wsort)
   write (*,*) sorted(n, wsort, 'DESC')
   write (*,*) 'elapsed time = ', t2-t1, ' secs.'
   deallocate (wshuf)
   deallocate (wsort)
end program mergesort


!==============================================================================!
  subroutine Sort_Mod_Unique_Int(values, nu)
!------------------------------------------------------------------------------!
  implicit none
!------------------------------------------------------------------------------!
!   Sorts an array of unique values in ascending order for an input array of   !
!   unsorted integers.  The original array is overwritten, the number of       !
!   unique members is returned in argument "nu".                               !
!---------------------------------[Arguments]----------------------------------!
  integer :: values(:)
  integer :: nu
!-----------------------------------[Locals]-----------------------------------!
  integer              :: i, min_val, max_val
  integer, allocatable :: unique(:)
!------------------------------------------------------------------------------!

  nu = size(values, 1)

  allocate(unique(nu)); unique(:) = 0

  min_val = minval(values) - 1
  max_val = maxval(values)

  i = 0
  do while(min_val < max_val)
    i = i+1
    min_val = minval(values, mask = values > min_val)
    unique(i) = min_val
  end do

  nu = i
  values(1:i) = unique(1:i)

  end subroutine


module residuo_interface
  interface
    subroutine residuo(a, b, u, r)
      real(8), dimension(:,:), intent(in) :: a
      real(8), dimension(:), intent(in) :: b
      real(8), dimension(:), intent(in) :: u
      real(8), dimension(:), intent(inout) :: r
    end subroutine
  end interface
end module


C++****************************************************************************
C Program SHIFT
C To shift an image of a some fractions of pixels
C and create of a larger image.
C JLP Version of 06-12-90
C--***************************************************************************
	PROGRAM SHIFT
	INTEGER*4 MADRID(1),PNTR_IN1,PNTR_OUT
	CHARACTER FILENAME*40,COMMENTS*80
	COMMON/VMR/MADRID

	PRINT 60
60	FORMAT(' Program to shift an image of some fractions'
     1	' of pixels',/,' and create a larger image',
     1	' (Dynamical allocation of memory)')

10	FORMAT(A)

	CALL JLP_BEGIN
	CALL JLP_INQUIFMT

C**** Input of the image *****************
        WRITE(6,*) 'Input file: '
        READ(5,10) FILENAME
	CALL JLP_VM_READIMAG(PNTR_IN1,NX1,NY1,FILENAME,COMMENTS)

	PRINT *,' OUTPUT = (INPUT - SKY ) * CTE'
	PRINT *,' Enter SKY value and constant CTE'
	READ(5,*) SKY1,CTE1
	PRINT *,' SHIFT IN X AND Y :'
	READ(5,*) DDX1,DDY1
	PRINT *,' SIZE OF THE OUTPUT IMAGE (NX, NY)  (0,0 if same size)?'
	READ(5,*) NX2,NY2
        IF(NX2.EQ.0.OR.NY2.EQ.0)THEN
          NX2=NX1
          NY2=NY1
        ENDIF

C Allocating dynamical memory space :
	MEMS_OUT=4*NX2*NY2
	CALL JLP_GETVM(PNTR_OUT,MEMS_OUT)

	CALL SHIFT1(MADRID(PNTR_IN1),NX1,NY1,MADRID(PNTR_OUT),NX2,NY2,
     1	DDX1,DDY1,SKY1,CTE1)

C Output of the image :
        WRITE(6,*) 'Output file: (image 1 shifted)'
        READ(5,10) FILENAME
	COMMENTS=' '
	CALL JLP_WRITEIMAG(MADRID(PNTR_OUT),NX2,NY2,NX2,
     1	FILENAME,COMMENTS)

	CALL JLP_END
	STOP
	END

C--------------------------------------------------------------------
C Subroutine SHIFT1 to shift IMAGE1 with a shift of DDX and DDY
C The output is stored in IMAGE2 of a large size NPL2, NL2.
C-------------------------------------------------------------------
	SUBROUTINE SHIFT1(IMAGE1,NPL1,NL1,IMAGE2,NPL2,NL2,
     1	DDX,DDY,SKY,CTE)
	REAL*4 IMAGE1(NPL1,NL1),IMAGE2(NPL2,NL2)

C--------------------------------------------------------------------
C Getting the parameters for the shift :
	IDDX=IFIX(DDX)
	TDX=DDX-FLOAT(IDDX)

	IF(TDX.LT.0.)THEN
	TDX=TDX+1.
	IDDX=IDDX-1
	ENDIF

	IDDY=IFIX(DDY)
	TDY=DDY-FLOAT(IDDY)

	IF(TDY.LT.0.)THEN
	TDY=TDY+1.
	IDDY=IDDY-1
	ENDIF

	PRINT 400,IDDX,TDX,IDDY,TDY
400	FORMAT(/,' IDDX =',I4,' TDX=',F7.3,' IDDY=',I4,
     1	' TDY=',F7.3)

C-------------------------------------------------------------------------
C Main loop

	DO 1 J=1,NL2
	JD=J-IDDY

	IF(JD.LT.2.OR.JD.GT.NL1)THEN
	DO I=1,NPL2
	IMAGE2(I,J)=0.
	END DO

	ELSE

	DO I=1,NPL2
	ID=I-IDDX
	  IF(ID.LT.2.OR.ID.GT.NPL1) THEN
	  IMAGE2(I,J)=0.
	  ELSE
 	  WORK=IMAGE1(ID,JD-1)*(1.-TDX)*TDY
     1	+IMAGE1(ID-1,JD-1)*TDX*TDY
     1	+IMAGE1(ID,JD)*(1.-TDX)*(1.-TDY)
     1	+IMAGE1(ID-1,JD)*TDX*(1.-TDY)
	  IMAGE2(I,J)=(WORK-SKY)*CTE
	  ENDIF
	END DO

	ENDIF

1	CONTINUE

	RETURN
	END


program drive

  use regression
  implicit none

  integer, parameter :: nr = 1, np = 1000
  real, dimension(nr) :: x, y, a, b, eps
  type (reg_type), dimension(nr) :: r
  integer :: i, j
  real :: avg

  do
     write (*,*) 'x, y'
     read (*,*,err=100) x(1), y(1)
     call regress (r, x, y)
     write (*,*) r%a, r%b
  end do

100 continue

  write (*,*) 'x, y'
  read (*,*,err=100) x(1), y(1)
  call regress (r, x, y, a, b)

  write (*,*) 'Final values:'
  write (*,*) 'a(1) = ',a(1),'     b(1) = ',b(1)
!  write (*,*) 'a(2) = ',a(2),'     b(2) = ',b(2)

  x(1) = 10.
!  x(2) = 10.

  write (*,*)
  write (*,*) 'x(1) = ',x(1)!,' x(2) = ',x(2)
  write (*,*) 'y= ',yp(r, x)

  y(1) = 36.
!  y(2) = -3.

  write (*,*)
  write (*,*) 'y(1) = ',y(1)!,' y(2) = ',y(2)
  write (*,*) 'x= ',xp(r, y)

end program drive