* FORTRAN test file to implement the DATA statement
* This file uses the DATA statement to assign arrays using implied DO loops
* Constructs of these types are yet to be handled and will be implemented if
* need be
**********************************************************************
* Expected Output: A:
*                  1.0  3.0
*				   2.0  4.0
*
*				   R:
*			   	   1.0  1.0
*			       1.0  1.0
*			       1.0  1.0
*
*			       S:
*			       1.0  0.0  0.0  0.0
*			       0.0  1.0  0.0  0.0
*			       0.0  0.0  1.0  0.0
*			       0.0  0.0  0.0  1.0
*
*			       B:
*			       1.1  2.1
*			       3.1  4.1
*
*			       C:
*			       2.0  2.0  2.0  2.0  2.0  2.0  2.0  2.0  2.0  2.0
*
*			       MATRIX:
*			       1.0  1.0  1.0  1.0  1.0  1.0  1.0  1.0  1.0  1.0
*			       1.0  0.0  0.0  0.0  0.0  0.0  0.0  0.0  0.0  1.0
*			       1.0  0.0  0.0  0.0  0.0  0.0  0.0  0.0  0.0  1.0
*			       1.0  0.0  0.0  0.0  0.0  0.0  0.0  0.0  0.0  1.0
*			       1.0  0.0  0.0  0.0  0.0  0.0  0.0  0.0  0.0  1.0
*			       1.0  0.0  0.0  0.0  0.0  0.0  0.0  0.0  0.0  1.0
*			       1.0  0.0  0.0  0.0  0.0  0.0  0.0  0.0  0.0  1.0
*			       1.0  0.0  0.0  0.0  0.0  0.0  0.0  0.0  0.0  1.0
*			       1.0  0.0  0.0  0.0  0.0  0.0  0.0  0.0  0.0  1.0
*			       1.0  1.0  1.0  1.0  1.0  1.0  1.0  1.0  1.0  1.0
**********************************************************************

      PROGRAM MAIN

      IMPLICIT NONE

      REAL, DIMENSION(10) :: C
      REAL, DIMENSION(3,2) :: R
      REAL, DIMENSION(4,4) :: S

      INTEGER :: I, J
      REAL, DIMENSION(10,10) :: MATRIX

      DATA (C(I), I=1,10) /10*2.0/
      DATA ((R(I,J),J=1,2),I=1,3) /6*1.0/
      DATA (S(I,I), I=1,4) /4*1.0/

      DATA MATRIX(1,    1:10) / 10*1.0  / ! TOP ROW
      DATA MATRIX(10,  1:10) / 10*1.0  / ! BOT ROW
      DATA MATRIX(2:9, 1)     / 8*1.0   / ! LEFT COL
      DATA MATRIX(2:9, 10)   / 8*1.0   / ! RIGHT COL
      DATA MATRIX(2:9, 2:9)  / 64*0.0 / ! INTERIOR

      WRITE (*,11)
      WRITE (*,12) 'R: '
      DO I = 1, 3
          WRITE (*,20) R(I,1), R(I,2)
      END DO

      WRITE (*,11)
      WRITE (*,12) 'S: '
      DO I = 1, 4
          WRITE (*,30) S(I,1), S(I,2), S(I,3), S(I,4)
      END DO

      WRITE (*,11)
      WRITE (*,12) 'C: '
      WRITE (*,40) C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9),
     &             C(10)

      WRITE (*,11)
      WRITE (*,12) 'MATRIX: '
      DO I = 1, 10
          WRITE (*,40) MATRIX(I,1), MATRIX(I,2), MATRIX(I,3),
     &          MATRIX(I,4), MATRIX(I,5), MATRIX(I,6), MATRIX(I,7),
     &          MATRIX(I,8), MATRIX(I,9), MATRIX(I,10)
      END DO

 11   FORMAT('')
 12   FORMAT(A)
 20   FORMAT(2(F3.1,2X))
 30   FORMAT(4(F3.1,2X))
 40   FORMAT(10(F3.1,2X))

      END PROGRAM MAIN


      SUBROUTINE AGC(BUFIN,BUFOUT,SCRBUF,SPEC)
C     AGC CALCULATES AND APPLIES AGC (AUTOMATIC GAIN CONTROL) TO AN ARRAY OF REAL
C VALUES (A SEISMIC TRACE).  AGC IS A TYPE OF SCALING SUCH THAT THE AVERAGE
C ABSOLUTE VALUE OF THE AMPLITUDES WITHIN A WINDOW WILL BE A CERTAIN LEVEL
C AFTER SCALING.
C     THIS AGC PROGRAM DIFFERS FROM OTHER AGCS IN THE WAY IT HANDLES ZERO (OR
C NEAR ZERO) INPUT AMPLITUDES.  IF THE WINDOW CONTAINS TOO MANY ZEROES, THE
C CALCULATED MULTIPLIER FOR THAT WINDOW IS IGNORED AND THE LAST ONE IS USED.
C E.G. IN THE CASE OF MUTES PRIOR TO P-BREAKS, THE FIRST MULTIPLIER WILL BE
C CALCULATED FROM SAY 75 PERCENT LIVE VALUES, THUS PREVENTING THE P-BREAKS FROM
C BEING OVERDRIVEN.
C     ANY TRACE WITH ALL AMPLITIDES BELOW A CERTAIN LEVEL (DEAD) WILL BE SET TO
C ZERO.
C
C   AGC VARIABLES:
C   ARGUMENTS:
C   BUFIN  - THE INPUT ARRAY (REAL)
C   BUFOUT -  THE OUTPUT ARRAY (REAL) - THE INPUT AND OUTPUT ARRAYS MAY BE THE
C             SAME.
C   SCRBUF  - A SCRATCH ARRAY (REAL) - MUST BE INDXET LONG
C    SPEC   - SPECIAL CASE SWITCH
C           <0, PRINT THE AVERAGE ABSOLUTE VALUE FOR EACH WINDOW
C           =0, DO NOTHING SPECIAL
C COMMON VARIABLE:
C   INDXST  - THE INDX OF THE FIRST SAMPLE IN BUFIN TO PROCESS.  BUFOUT WILL
C             HAVE UNTOUCHED DATA VALUES PRIOR TO INDXST.  THIS PARAMETER CAN BE
C             NON-ZERO IN ORDER TO AVOID SCALING THE WATER LAYER (SAY CPU TIME).
C             THIS SHOULD BE 1 IN MOST CASES.
C   INDXET - THE INDEX OF BUFIN OF THE LAST SAMPLE TO PROCESS.  THE NUMBER OF
C            SAMPLES IN THE ARRAY (WHEN INDXET IS 1).
C   OLEVEL - THE OUTPUT AMPLITUDE LEVEL.  THE AVERAGE ABSOLUTE VALUE.
C   CLIP   - THE CLIP LEVEL.  ANY AMPLITUDE (ABS VALUE) EXCEEDING THE CLIP
C            VALUE WILL BE SET TO CLIP.
C   NPTS   - THE NUMBER OF SAMPLES IN EACH WINDOW( THE WINDOW LENGTH IN SAMPLES)
C            REMEMBER THAT THE WINDOW IS SLIDE (ADVANCED) BY ONE SAMPLE
C   NDEAD  - THE NUMBER OF DEAD VALUES TO ALLOW IN A WINDOW IN ORDER TO GET A
C            NEW WINDOW MULTIPLIER.
C   DEAD   - A LEVEL BELOW WHICH AN AMPLITUDE IS CONSIDERED DEAD.
C   MIDPT  - THE MID POINT OF THE WINDOW TO RECEIVE THE MULTIPLIER FOR THE WINDOW
C            A FORWARD LOOKING WINDOW WOULD HAVE MIDPT=1
c   agcpct - The percent AGC, expressed as percent/100.  agcpct
c            multiplies the multiplier.  An agcpct < 1 has the
c            effect of lessening the AGC (makes it "softer").
C
C
C    PAUL HENKART, SCRIPPS INSTITUTION OF OCEANOGRAPHY, JANUARY 1979
c  mod 13 April 1991 by pch - add agcpct
c  mod June 96 by s.s - change the way agcpct works
c
      COMMON /AGCCOM/ INDXST,INDXET,OLEVEL,CLIP,NPTS,NDEAD,DEAD,MIDPT,
     &     agcpct
      DIMENSION BUFIN(1),BUFOUT(1),SCRBUF(1)
      LOGICAL FIRST
      double precision agctot, agcmean
      FIRST=.TRUE.
      NZEROS=0
      SUM=0.
      NDONE=0
C****
C****       PUT THE ABSOLUTE VALUES INTO SCRBUF
C****
      DO 100 I = 1, INDXET
      SCRBUF(I)=ABS(BUFIN(I))
  100 CONTINUE
c  S.S  percent agc change.  First, find the average absolute value of nonzero
c    samples for the entire trace
      if( agcpct .ne. 1.) then
        agctot = 0
        nnonzero = 0
        do 110 i=1,indxet
          if(scrbuf(i) .ne. 0.) then
            agctot = agctot + abs(scrbuf(i))
            nnonzero = nnonzero + 1
          endif
110     continue
        agcmean = agctot / nnonzero
c        write (*,*) 'agcmean ',agcmean,' agcpct',agcpct
      endif
C****
C****            FIND THE FIRST WINDOW WITH A GOOD MULTIPLIER
C****
      INDX=INDXST-1
      DO 190 I = 1, NPTS                                                !  DO THE FIRST WINDOW
         J = INDX + I
         IF( SCRBUF(J) .GT. DEAD ) THEN
             SUM = SUM + SCRBUF(J)
         ELSE
             NZEROS = NZEROS + 1
         ENDIF
  190 CONTINUE
  200 CONTINUE
      NDONE = NDONE + 1
      IF(NZEROS.LT.NDEAD) GO TO 300
      J=INDXST+NDONE-1
      K = J + NPTS
      IF(K.GT.INDXET) GO TO 250
      IF( SCRBUF(J).LE.DEAD) THEN
          NZEROS = NZEROS - 1
          IF( nzeros .LT. 0 ) nzeros = 0
      ELSE
          SUM = SUM - SCRBUF(J)
      ENDIF
      IF( SCRBUF(K) .LE. DEAD ) THEN
          NZEROS = NZEROS + 1
          IF( nzeros .GT. npts ) nzeros = npts
      ELSE
          SUM = SUM + SCRBUF(K)
      ENDIF
      GO TO 200
C****
C****           THE TRACE IS DEAD HERE
C****
  250 CONTINUE
      DO 260 I = 1, INDXET                                              ! MOVE THE INPUT WITHOUT CHANGING THE AMPLITUDES
  260 BUFOUT(I)=BUFIN(I)
      PRINT 270
  270 FORMAT(' ***  WARNING  ***  NOT ENOUGH NON-ZERO VALUES IN ORDER',
     *   ' TO AGC, NO AGC APPLIED.')
      RETURN
C****
C****
  300 CONTINUE
      TEMP=FLOAT(NPTS-NZEROS)                                           ! CHECK FOR NUMBER SIZE
      IF( TEMP .LE. 0. ) THEN
          AVE = CLIP
      ELSE
          AVE = SUM / TEMP
      ENDIF
      IF(AVE.EQ.0.) AVE=.00000001
      IF( SPEC .LT. 0 ) PRINT *,' ave=',ave,' ndone=',ndone
C****
C****         MULTIPLY THE CENTRE POINT OF THE WINDOW AND ADVANCE THE WINDOW
C****         ONE SAMPLE AND REPEAT
C****           USE THE FIRST MULTIPLIER FOR ALL POINTS LESS THAN THE FIRST MID
C****      POINT
C****
c S.S.  changing way pctagc works
c      xmult = olevel / ave * agcpct
c      xmult = olevel / ave / (2.-agcpct)
      IF( agcpct .EQ. 1. ) THEN
          xmult = olevel / ave
      ELSE
          xmult = olevel / (ave + ((1.-agcpct) * agcmean))
      ENDIF
      IF( FIRST ) THEN
          FIRST = .FALSE.
          N = INDXST + NDONE + MIDPT - 3
          DO 390 I = 1, N
             BUFOUT(I) = BUFIN(I) * XMULT
             IF( CLIP .NE. 0. ) THEN
                 IF( ABS(BUFOUT(I)) .GT. CLIP )
     *               BUFOUT(I) = SIGN(CLIP,BUFIN(I))
             ENDIF
  390     CONTINUE
      ENDIF
  400 CONTINUE
      I = INDXST + NDONE + MIDPT - 2
      BUFOUT(I) = BUFIN(I) * XMULT
      IF( CLIP .NE. 0.) THEN
          IF( ABS(BUFOUT(I)) .GT. CLIP )
     *        BUFOUT(I) = SIGN(CLIP,BUFIN(I))
      ENDIF
      IF( INDXST+NPTS+NDONE-1 .GT. INDXET ) GOTO 1000
      J=INDXST+NDONE-1
      K=J+NPTS
      IF( SCRBUF(J) .LE. DEAD ) THEN
          NZEROS = NZEROS - 1
          IF( nzeros .LT. 0 ) nzeros = 0
      ELSE
          SUM = SUM - SCRBUF(J)
      ENDIF
      IF( SCRBUF(K) .LE. DEAD ) THEN
          NZEROS = NZEROS + 1
          IF( nzeros .GT. npts ) nzeros = npts
      ELSE
          SUM = SUM + SCRBUF(K)
      ENDIF
      NDONE = NDONE + 1
      IF( NZEROS .LT. NDEAD ) GOTO 300
      GOTO 400
C****
C****            FINISHED FINDING XMULTIPLIERS, NOW FINISH THE REMAINDER OF THE
C****       LAST WINDOW
C****
 1000 CONTINUE
      J=INDXST+NDONE+MIDPT-1
      DO 1010 I=J,INDXET
      BUFOUT(I)=BUFIN(I)*XMULT
      IF(CLIP.EQ.0.) GO TO 1010
      IF(ABS(BUFOUT(I)).GT.CLIP) BUFOUT(I)=SIGN(CLIP,BUFIN(I))
 1010 CONTINUE
      RETURN
      END


c  cspline -- dmc 15 Feb 1999
c
c  a standard interface to the 1d spline setup routine
c    modified dmc 3 Mar 2000 -- to use Wayne Houlberg's v_spline code.
c    new BC options added.
c
      subroutine r8cspline(x,nx,fspl,ibcxmin,bcxmin,ibcxmax,bcxmax,
     >   wk,iwk,ilinx,ier)
c
!============
! idecl:  explicitize implicit INTEGER declarations:
      IMPLICIT NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      INTEGER iwk,nx,ierx,inum,i
!============
! idecl:  explicitize implicit REAL declarations:
      REAL*8 half,sixth
!============
      REAL*8 x(nx)                        ! x axis (in)
      REAL*8 fspl(4,nx)                   ! spline data (in/out)
      integer ibcxmin                   ! x(1) BC flag (in, see comments)
      REAL*8 bcxmin                       ! x(1) BC data (in, see comments)
      integer ibcxmax                   ! x(nx) BC flag (in, see comments)
      REAL*8 bcxmax                       ! x(nx) BC data (in, see comments)
      REAL*8 wk(iwk)                      ! workspace of size at least nx
      integer ilinx                     ! even spacing flag (out)
      integer ier                       ! output, =0 means OK
c
c  ** note wk(...) array is not used unless ibcxmin=-1 (periodic spline
c  evaluation)
c
c  this routine computes spline coefficients for a 1d spline --
c  evaluation of the spline can be done by cspeval.for subroutines
c  or directly by inline code.
c
c  the input x axis x(1...nx) must be strictly ascending, i.e.
c  x(i+1).gt.x(i) is required for i=1 to nx-1.  This is checked and
c  ier=1 is set and the routine exits if the test is not satisfied.
c
c  on output, ilinx=1 is set if, to a reasonably close tolerance,
c  all grid spacings x(i+1)-x(i) are equal.  This allows a speedier
c  grid lookup algorithm on evaluation of the spline.  If on output
c  ilinx=2, this means the spline x axis is not evenly spaced.
c
c  the input data for the spline are given in f[j] = fspl(1,j).  The
c  output data are the spline coefficients fspl(2,j),fspl(3,j), and
c  fspl(4,j), j=1 to nx.  The result is a spline s(x) satisfying the
c  boundary conditions and with the properties
c
c     s(x(j)) = fspl(1,j)
c     s'(x) is continuous even at the grid points x(j)
c     s''(x) is continuous even at the grid points x(j)
c
c  the formula for evaluation of s(x) is:
c
c     let dx = x-x(i), where x(i).le.x.le.x(i+1).  Then,
c     s(x)=fspl(1,i) + dx*(fspl(2,i) +dx*(fspl(3,i) + dx*fspl(4,i)))
c
c  ==>boundary conditions.  Complete specification of a 1d spline
c  requires specification of boundary conditions at x(1) and x(nx).
c
c  this routine provides 4 options:
c
c -1 ***** PERIODIC BC
c  ibcxmin=-1  --  periodic boundary condition.  This means the
c    boundary conditions s'(x(1))=s'(x(nx)) and s''(x(1))=s''(x(nx))
c    are imposed.  Note that s(x(1))=s(x(nx)) (i.e. fspl(1,1)=fspl(1,nx))
c    is not required -- that is determined by the fspl array input data.
c    The periodic boundary condition is to be preferred for periodic
c    data.  When splining periodic data f(x) with period P, the relation
c    x(nx)=x(1)+n*P, n = the number of periods (usually 1), should hold.
c    (ibcxmax, bcxmin, bcxmax are ignored).
c
c  if a periodic boundary condition is set, this covers both boundaries.
c  for the other types of boundary conditions, the type of condition
c  chosen for the x(1) boundary need not be the same as the type chosen
c  for the x(nx) boundary.
c
c  0 ***** NOT A KNOT BC
c  ibcxmin=0 | ibcxmax=0 -- this specifies a "not a knot" boundary
c    condition -- see cubsplb.for.  This is a common way for inferring
c    a "good" spline boundary condition automatically from data in the
c    vicinity of the boundary.  (bcxmin | bcxmax are ignored).
c
c  1 ***** BC:  SPECIFIED SLOPE
c  ibcxmin=1 | ibcxmax=1 -- boundary condition is to have s'(x(1)) |
c    s'(x(nx)) match the passed value (bcxmin | bcxmax).
c
c  2 ***** BC:  SPECIFIED 2nd DERIVATIVE
c  ibcxmin=2 | ibcxmax=2 -- boundary condition is to have s''(x(1)) |
c    s''(x(nx)) match the passed value (bcxmin | bcxmax).
c
c  3 ***** BC:  SPECIFIED SLOPE = 0.0
c  ibcxmin=3 | ibcxmax=3 -- boundary condition is to have s'(x(1)) |
c    s'(x(nx)) equal to ZERO.
c
c  4 ***** BC:  SPECIFIED 2nd DERIVATIVE = 0.0
c  ibcxmin=4 | ibcxmax=4 -- boundary condition is to have s''(x(1)) |
c    s''(x(nx)) equal to ZERO.
c
c  5 ***** BC:  1st DIVIDED DIFFERENCE
c  ibcxmin=5 | ibcxmax=5 -- boundary condition is to have s'(x(1)) |
c    s'(x(nx)) equal to the slope from the 1st|last 2 points
c
c  6 ***** BC:  2nd DIVIDED DIFFERENCE
c  ibcxmin=6 | ibcxmax=6 -- boundary condition is to have s''(x(1)) |
c    s''(x(nx)) equal to the 2nd derivative from the 1st|last 3 points
c
c  7 ***** BC:  3rd DIVIDED DIFFERENCE
c  ibcxmin=7 | ibcxmax=7 -- boundary condition is to have s'''(x(1)) |
c    s'''(x(nx)) equal to the 3rd derivative from the 1st|last 4 points
c
c---------------------------------------------------------------------
      data half/0.5_r8/
      data sixth/0.166666666666666667_r8/
c
c  error checks
c
      ier = 0
      if(nx.lt.2) then
         write(6,'('' ?cspline:  at least 2 x points required.'')')
         ier=1
      endif
      call ibc_ck(ibcxmin,'cspline','xmin',-1,7,ier)
      if(ibcxmin.ge.0) call ibc_ck(ibcxmax,'cspline','xmax',0,7,ier)
c
c  x axis check
c
      call r8splinck(x,nx,ilinx,1.0E-3_r8,ierx)
      if(ierx.ne.0) ier=2
c
      if(ier.eq.2) then
         write(6,'('' ?cspline:  x axis not strict ascending'')')
      endif
c
      if(ibcxmin.eq.-1) then
         inum=nx
         if(iwk.lt.inum) then
            write(6,1009) inum,iwk,nx
 1009       format(
     >      ' ?cspline:  workspace too small.  need:  ',i6,' got:  ',i6/
     >      '  (need = nx, nx=',i6)
            ier=3
         endif
      endif
c
      if(ier.ne.0) return
c
c  OK -- evaluate spline
c
      if(ibcxmin.eq.1) then
         fspl(2,1)=bcxmin
      else if(ibcxmin.eq.2) then
         fspl(3,1)=bcxmin
      endif
c
      if(ibcxmax.eq.1) then
         fspl(2,nx)=bcxmax
      else if(ibcxmax.eq.2) then
         fspl(3,nx)=bcxmax
      endif
c
      call r8v_spline(ibcxmin,ibcxmax,nx,x,fspl,wk)
c
      do i=1,nx
         fspl(3,i)=half*fspl(3,i)
         fspl(4,i)=sixth*fspl(4,i)
      enddo
c
      return
      end


c \BeginDoc
c
c \Name: cnband
c
c \Description:
c  This subroutine returns the converged approximations to eigenvalues
c  of A*z = lambda*B*z and (optionally):
c
c      (1) The corresponding approximate eigenvectors;
c
c      (2) An orthonormal basis for the associated approximate
c          invariant subspace;
c
c      (3) Both.
c
c  Matrices A and B are stored in LAPACK-style banded form.
c
c  There is negligible additional cost to obtain eigenvectors.  An orthonormal
c  basis is always computed.  There is an additional storage cost of n*nev
c  if both are requested (in this case a separate array Z must be supplied).
c
c  The approximate eigenvalues and eigenvectors of  A*z = lambda*B*z
c  are commonly called Ritz values and Ritz vectors respectively.  They are
c  referred to as such in the comments that follow.  The computed orthonormal
c  basis for the invariant subspace corresponding to these Ritz values is
c  referred to as a Schur basis.
c
c  cnband can be called with one of the following modes:
c
c  Mode 1:  A*z = lambda*z.
c           ===> OP = A  and  B = I.
c
c  Mode 2:  A*z = lambda*M*z, M symmetric positive definite
c           ===> OP = inv[M]*A  and  B = M.
c
c  Mode 3:  A*z = lambda*M*z, M symmetric semi-definite
c           ===> OP = inv[A - sigma*M]*M   and  B = M.
c           ===> shift-and-invert mode.
c
c  Choice of different modes can be specified in IPARAM(7) defined below.
c
c \Usage
c   call cnband
c      ( RVEC, HOWMNY, SELECT, D , Z, LDZ, SIGMA, WORKEV, N, AB,
c        MB, LDA, FAC, KL, KU, WHICH, BMAT, NEV, TOL, RESID, NCV,
c        V, LDV, IPARAM, WORKD, WORKL, LWORKL, RWORK, IWORK, INFO )
c
c \Arguments
c  RVEC    LOGICAL  (INPUT)
c          Specifies whether a basis for the invariant subspace corresponding
c          to the converged Ritz value approximations for the eigenproblem
c          A*z = lambda*B*z is computed.
c
c             RVEC = .FALSE.     Compute Ritz values only.
c
c             RVEC = .TRUE.      Compute Ritz vectors or Schur vectors.
c                                See Remarks below.
c
c  HOWMNY  Character*1  (INPUT)
c          Specifies the form of the invariant subspace to be computed
c          corresponding to the converged Ritz values.
c          = 'A': Compute NEV Ritz vectors;
c          = 'P': Compute NEV Schur vectors;
c          = 'S': compute some of the Ritz vectors, specified
c                 by the logical array SELECT.
c
c  SELECT  Logical array of dimension NCV.  (INPUT)
c          If HOWMNY = 'S', SELECT specifies the Ritz vectors to be
c          computed. To select the real Ritz vector corresponding to a
c          Ritz value D(j), SELECT(j) must be set to .TRUE..
c          If HOWMNY = 'A' or 'P', SELECT need not be initialized
c          but it is used as internal workspace.
c
c  D       Complex  array of dimension NEV+1.  (OUTPUT)
c          On exit, D contains the  Ritz  approximations
c          to the eigenvalues lambda for A*z = lambda*B*z.
c
c  Z       Complex  N by NEV array     (OUTPUT)
c          On exit, if RVEC = .TRUE. and HOWMNY = 'A', then the columns of
c          Z represents approximate eigenvectors (Ritz vectors) corresponding
c          to the NCONV=IPARAM(5) Ritz values for eigensystem
c          A*z = lambda*B*z.
c
c          If RVEC = .FALSE. or HOWMNY = 'P', then Z is NOT REFERENCED.
c
c          NOTE: If if RVEC = .TRUE. and a Schur basis is not required,
c          the array Z may be set equal to first NEV columns of the
c          array V.
c
c  LDZ     Integer.  (INPUT)
c          The leading dimension of the array Z.  If Ritz vectors are
c          desired, then  LDZ .ge.  max( 1, N ) is required.
c          In any case,  LDZ .ge. 1 is required.
c
c  SIGMA   Complex   (INPUT)
c          If IPARAM(7) = 3 then SIGMA represents the shift.
c          Not referenced if IPARAM(7) = 1 or 2.
c
c  WORKEV  Complex  work array of dimension NCV.  (WORKSPACE)
c
c  N       Integer.  (INPUT)
c          Dimension of the eigenproblem.
c
c  AB      Complex  array of dimension LDA by N. (INPUT)
c          The matrix A in band storage, in rows KL+1 to
c          2*KL+KU+1; rows 1 to KL of the array need not be set.
c          The j-th column of A is stored in the j-th column of the
c          array AB as follows:
c          AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
c
c  MB      Complex  array of dimension LDA by N. (INPUT)
c          The matrix M in band storage, in rows KL+1 to
c          2*KL+KU+1; rows 1 to KL of the array need not be set.
c          The j-th column of M is stored in the j-th column of the
c          array MB as follows:
c          MB(kl+ku+1+i-j,j) = M(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
c          Not referenced if IPARAM(7)=1.
c
c  LDA     Integer. (INPUT)
c          Leading dimension of AB, MB, FAC.
c
c  FAC     Complex  array of LDA by N. (WORKSPACE/OUTPUT)
c          FAC is used to store the LU factors of MB when mode 2
c          is invoked.  It is used to store the LU factors of
c          (A-sigma*M) when mode 3 is invoked.
c          It is not referenced when IPARAM(7)=1.
c
c  KL      Integer. (INPUT)
c          Max(number of subdiagonals of A, number of subdiagonals of M)
c
c  KU      Integer. (OUTPUT)
c          Max(number of superdiagonals of A, number of superdiagonals of M)
c
c  WHICH   Character*2.  (INPUT)
c          When mode 1,2 are used, WHICH can be set to any one of
c          the following.
c
c            'LM' -> want the NEV eigenvalues of largest magnitude.
c            'SM' -> want the NEV eigenvalues of smallest magnitude.
c            'LR' -> want the NEV eigenvalues of largest real part.
c            'SR' -> want the NEV eigenvalues of smallest real part.
c            'LI' -> want the NEV eigenvalues of largest imaginary part.
c            'SI' -> want the NEV eigenvalues of smallest imaginary part.
c
c          When mode 3 is used, WHICH should be set to 'LM' only.
c
c  BMAT    Character*1.  (INPUT)
c          BMAT specifies the type of the matrix B that defines the
c          semi-inner product for the operator OP.
c          BMAT = 'I' -> standard eigenvalue problem A*x = lambda*x
c          BMAT = 'G' -> generalized eigenvalue problem A*x = lambda*M*x

c  NEV     Integer. (INPUT)
c          Number of eigenvalues of to be computed.
c
c  TOL     Real  scalar.  (INPUT)
c          Stopping criteria: the relative accuracy of the Ritz value
c          is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I))
c          where ABS(RITZ(I)) is the magnitude when RITZ(I) is complex.
c          DEFAULT = slamch('EPS')  (machine precision as computed
c                    by the LAPACK auxilliary subroutine slamch).
c
c  RESID   Complex  array of length N.  (INPUT/OUTPUT)
c          On INPUT:
c          If INFO .EQ. 0, a random initial residual vector is used.
c          If INFO .NE. 0, RESID contains the initial residual vector,
c                          possibly from a previous run.
c          On OUTPUT:
c          RESID contains the final residual vector.
c
c  NCV     Integer.  (INPUT)
c          Number of columns of the matrix V. NCV must satisfy the two
c          inequalities 2 <= NCV-NEV and NCV <= N.
c          This will indicate how many Arnoldi vectors are generated
c          at each iteration.  After the startup phase in which NEV
c          Arnoldi vectors are generated, the algorithm generates
c          approximately NCV-NEV Arnoldi vectors at each subsequent update
c          iteration. Most of the cost in generating each Arnoldi vector is
c          in the matrix-vector operation OP*x.
c
c  V       Complex  array N by NCV.  (OUTPUT)
c          Upon OUTPUT: If RVEC = .TRUE. the first NCONV=IPARAM(5) columns
c                       contain approximate Schur vectors that span the
c                       desired invariant subspace.
c
c          NOTE: If the array Z has been set equal to first NEV+1 columns
c          of the array V and RVEC=.TRUE. and HOWMNY= 'A', then
c          the first NCONV=IPARAM(5) columns of V will contain Ritz vectors
c          of the eigensystem A*z = lambda*B*z.
c
c  LDV     Integer.  (INPUT)
c          Leading dimension of V exactly as declared in the calling
c          program.  LDV must be great than or equal to N.
c
c  IPARAM  Integer array of length 11.  (INPUT/OUTPUT)
c          IPARAM(1) = ISHIFT:
c          The shifts selected at each iteration are used to restart
c          the Arnoldi iteration in an implicit fashion.
c          It is set to 1 in this subroutine.  The user do not need
c          to set this parameter.
c           ----------------------------------------------------------
c          ISHIFT = 1: exact shift with respect to the current
c                      Hessenberg matrix H.  This is equivalent to
c                      restarting the iteration from the beginning
c                      after updating the starting vector with a linear
c                      combination of Ritz vectors associated with the
c                      "wanted" eigenvalues.
c          -------------------------------------------------------------
c
c          IPARAM(2) = Not referenced.
c
c          IPARAM(3) = MXITER
c          On INPUT:  max number of Arnoldi update iterations allowed.
c          On OUTPUT: actual number of Arnoldi update iterations taken.
c
c          IPARAM(4) = NB: blocksize to be used in the recurrence.
c          The code currently works only for NB = 1.
c
c          IPARAM(5) = NCONV: number of "converged" eigenvalues.
c
c          IPARAM(6) = IUPD
c          Not referenced. Implicit restarting is ALWAYS used.
c
c          IPARAM(7) = MODE
c          On INPUT determines what type of eigenproblem is being solved.
c          Must be 1,2 or 3; See under \Description of cnband for the
c          three modes available.
c
c WORKD    Complex  work array of length at least 3*n. (WORKSPACE)
c
c WORKL    Complex  work array of length LWORKL. (WORKSPACE)
c
c LWORKL   Integer.  (INPUT)
c          LWORKL must be at least 3*NCV**2 + 5*NCV.
c
c RWORK    Real  array of length N (WORKSPACE)
c          Workspace used in cnaupd.
c
c IWORK    Integer array of dimension at least N. (WORKSPACE)
c          Used to mode 2,3. Store the pivot information in the
c          factorization of M or (A-SIGMA*M).
c
c INFO     Integer.  (INPUT/OUTPUT)
c          Error flag on output.
c          =  0: Normal exit.
c          = -1: N must be positive.
c          = -2: NEV must be positive.
c          = -3: NCV-NEV >= 2 and less than or equal to N.
c          = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI'
c          = -6: BMAT must be one of 'I' or 'G'.
c          = -7: Length of private work WORKL array is not sufficient.
c          = -8: Error return from LAPACK eigenvalue calculation.
c                This should never happened.
c          = -10: IPARAM(7) must be 1,2,3.
c          = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible.
c          = -12: HOWMNY = 'S' not yet implemented
c          = -13: HOWMNY must be one of 'A' or 'P' if RVEC = .true.
c          = -14: CNAUPD did not find any eigenvalues to sufficient
c                 accuracy.
c
c \EndDoc
c
c------------------------------------------------------------------------
c
c\BeginLib
c
c\Routines called
c     cnaupd  ARPACK reverse communication interface routine.
c     cneupd  ARPACK routine that returns Ritz values and (optionally)
c             Ritz vectors.
c     cgbtrf  LAPACK band matrix factorization routine.
c     cgbtrs  LAPACK band linear system solve routine.
c     clacpy  LAPACK matrix copy routine.
c     ccopy   Level 1 BLAS that copies one vector to another.
c     scnrm2  Level 1 BLAS that computes the norm of a vector.
c     cgbmv   Level 2 BLAS that computes the band matrix vector product.
c
c\References:
c  1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c     a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c     pp 357-385.
c  2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
c     Restarted Arnoldi Iteration", Ph.D thesis, TR95-13, Rice Univ,
c     May 1995.
c
c\Author
c     Richard Lehoucq
c     Danny Sorensen
c     Chao Yang
c     Dept. of Computational &
c     Applied Mathematics
c     Rice University
c     Houston, Texas
c
c\SCCS Information: @(#)
c FILE: nband.F   SID: 2.3   DATE OF SID: 10/17/00   RELEASE: 2
c
c\EndLib
c
c-----------------------------------------------------------------------
c
      subroutine cnband(rvec, howmny, select, d , z, ldz, sigma,
     &                 workev, n, ab, mb, lda, fac, kl, ku, which,
     &                 bmat, nev, tol, resid, ncv, v, ldv, iparam,
     &                 workd, workl, lworkl, rwork, iwork, info )
c
c     %------------------%
c     | Scalar Arguments |
c     %------------------%
c
      Character        which*2, bmat, howmny
      Logical          rvec
      Integer          n, lda, kl, ku, nev, ncv, ldv,
     &                 ldz, lworkl, info
      Complex
     &                 sigma
      Real
     &                 tol
c
c     %-----------------%
c     | Array Arguments |
c     %-----------------%
c
      Integer          iparam(*), iwork(*)
      Logical          select(*)
      Complex
     &                 d(*), resid(*), v(ldv,*), z(ldz,*),
     &                 ab(lda,*), mb(lda,*), fac(lda,*),
     &                 workd(*), workl(*), workev(*)
      Real
     &                 rwork(*)
c
c     %--------------%
c     | Local Arrays |
c     %--------------%
c
      integer          ipntr(14)
c
c     %---------------%
c     | Local Scalars |
c     %---------------%
c
      integer          ido, i, j, mode, ierr, itop, imid, ibot
c
c     %------------%
c     | Parameters |
c     %------------%
c
      Complex
     &                  one, zero
      parameter        (one  = (1.0E+0, 0.0E+0) ,
     &                  zero = (0.0E+0, 0.0E+0) )
c
c     %-----------------------------%
c     | LAPACK & BLAS routines used |
c     %-----------------------------%
c
      Real
     &                 scnrm2
      external         ccopy, cgbmv, cgbtrf, cgbtrs, scnrm2, clacpy
c
c     %-----------------------%
c     | Executable Statements |
c     %-----------------------%
c
      mode = iparam(7)
c
c     %------------------------%
c     | Initialize the reverse |
c     | communication flag.    |
c     %------------------------%
c
      ido   = 0
c
c     %----------------%
c     | Exact shift is |
c     | used.          |
c     %----------------%
c
      iparam(1) = 1
c
c     %-----------------------------------%
c     | Both matrices A and M are stored  |
c     | between rows itop and ibot.  Imid |
c     | is the index of the row that      |
c     | stores the diagonal elements.     |
c     %-----------------------------------%
c
      itop = kl + 1
      imid = kl + ku + 1
      ibot = 2*kl + ku + 1
c
      if ( mode .eq. 2 ) then
c
c         %-----------------------------------------------%
c         | Copy M to fac and Call LAPACK routine cgbtrf  |
c         | to factor M.                                  |
c         %-----------------------------------------------%
c
          call clacpy ('A', ibot, n, mb, lda, fac, lda )
          call cgbtrf(n, n, kl, ku, fac, lda, iwork, ierr)
          if (ierr .ne. 0) then
              print*, ' '
              print*,'_band:  error in _gbtrf'
              print*, ' '
              go to 9000
          end if
c
      else if ( mode .eq. 3 ) then
c
          if (bmat .eq. 'I') then
c
c            %-------------------------%
c            | Construct (A - sigma*I) |
c            %-------------------------%
c
             call clacpy ('A', ibot, n, ab, lda, fac, lda )
             do 10 j = 1,n
                fac(imid,j) = ab(imid,j) - sigma
  10         continue
c
          else
c
c            %---------------------------%
c            | Construct (A - sigma*M)   |
c            %---------------------------%
c
             do 30 j = 1,n
                do 20 i = itop, ibot
                   fac(i,j) = ab(i,j) - sigma*mb(i,j)
  20            continue
  30         continue
c
          end if
c
c         %------------------------%
c         | Factor (A - sigma*M)   |
c         %------------------------%
c
          call cgbtrf(n, n, kl, ku, fac, lda, iwork, ierr)
          if ( ierr .ne. 0 )  then
              print*, ' '
              print*, '_band: error in _gbtrf.'
              print*, ' '
              go to 9000
          end if
c
      end if
c
c     %--------------------------------------------%
c     |  M A I N   L O O P (reverse communication) |
c     %--------------------------------------------%
c
  40  continue
c
      call cnaupd ( ido, bmat, n, which, nev, tol, resid, ncv,
     &              v, ldv, iparam, ipntr, workd, workl, lworkl,
     &              rwork,info )

c
      if (ido .eq. -1) then
c
         if ( mode .eq. 1) then
c
c           %----------------------------%
c           | Perform  y <--- OP*x = A*x |
c           %----------------------------%
c
            call cgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1),
     &                 lda, workd(ipntr(1)), 1, zero,
     &                 workd(ipntr(2)), 1)
c
         else if ( mode .eq. 2 ) then
c
c           %-----------------------------------%
c           | Perform  y <--- OP*x = inv[M]*A*x |
c           %-----------------------------------%
c
            call cgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1),
     &                  lda, workd(ipntr(1)), 1, zero,
     &                  workd(ipntr(2)), 1)
c
            call cgbtrs ('Notranspose', n, kl, ku, 1, fac, lda,
     &                    iwork, workd(ipntr(2)), n, ierr)
            if (ierr .ne. 0) then
               print*, ' '
               print*, '_band: error in sbgtrs.'
               print*, ' '
               go to 9000
            end if
c
         else if ( mode .eq. 3 ) then
c
c           %-----------------------------------------%
c           | Perform y <-- OP*x                      |
c           |           = inv[A-SIGMA*M]*M* x
c           | to force the starting vector into the   |
c           | range of OP.                            |
c           %-----------------------------------------%
c
            call cgbmv('Notranspose', n, n, kl, ku, one, mb(itop,1),
     &                 lda, workd(ipntr(1)), 1, zero,
     &                 workd(ipntr(2)), 1)
c
            call cgbtrs ('Notranspose', n, kl, ku, 1, fac, lda,
     &                   iwork, workd(ipntr(2)), n, ierr)
            if (ierr .ne. 0) then
               print*, ' '
               print*, '_band: error in _gbtrs.'
               print*, ' '
               go to 9000
            end if
c
         end if
c
      else if (ido .eq. 1) then
c
         if ( mode .eq. 1) then
c
c           %----------------------------%
c           | Perform  y <--- OP*x = A*x |
c           %----------------------------%
c
            call cgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1),
     &                 lda, workd(ipntr(1)), 1, zero,
     &                 workd(ipntr(2)), 1)
c
         else if ( mode .eq. 2 ) then
c
c           %-----------------------------------%
c           | Perform  y <--- OP*x = inv[M]*A*x |
c           %-----------------------------------%
c
            call cgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1),
     &                  lda, workd(ipntr(1)), 1, zero,
     &                  workd(ipntr(2)), 1)
c
            call cgbtrs ('Notranspose', n, kl, ku, 1, fac, lda,
     &                    iwork, workd(ipntr(2)), ldv, ierr)
            if (ierr .ne. 0) then
               print*, ' '
               print*, '_band: error in sbgtrs.'
               print*, ' '
               go to 9000
            end if
c
         else if ( mode .eq. 3 ) then
c
            if ( bmat .eq. 'I' ) then
c
c              %----------------------------------%
c              | Perform  y <-- inv(A-sigma*I)*x. |
c              %----------------------------------%
c
               call ccopy(n, workd(ipntr(1)), 1, workd(ipntr(2)), 1)
               call cgbtrs ('Notranspose', n, kl, ku, 1, fac, lda,
     &                    iwork, workd(ipntr(2)), n, ierr)
               if (ierr .ne. 0) then
                  print*, ' '
                  print*, '_band: error in _gbtrs.'
                  print*, ' '
                  go to 9000
               end if
c
            else
c
c              %--------------------------------------%
c              | Perform  y <-- inv(A-sigma*M)*(M*x). |
c              | (M*x) has been computed and stored   |
c              | in workd(ipntr(3)).                  |
c              %--------------------------------------%
c
               call ccopy(n, workd(ipntr(3)), 1, workd(ipntr(2)), 1)
               call cgbtrs ('Notranspose', n, kl, ku, 1, fac, lda,
     &                      iwork, workd(ipntr(2)), n, ierr)
               if (ierr .ne. 0) then
                  print*, ' '
                  print*, '_band: error in _gbtrs.'
                  print*, ' '
                  go to 9000
               end if
c
            end if
c
         endif
c
      else if (ido .eq. 2) then
c
c        %--------------------%
c        | Perform y <-- M*x  |
c        %--------------------%
c
          call cgbmv('Notranspose', n, n, kl, ku, one, mb(itop,1),
     &                lda, workd(ipntr(1)), 1, zero,
     &                workd(ipntr(2)), 1)
c
      else
c
c        %-------------------------------------------%
c        |   Either we have convergence, or there is |
c        |   error.                                  |
c        %-------------------------------------------%
c
         if ( info .ne. 0) then
c
c           %--------------------------%
c           | Error message, check the |
c           | documentation in dnaupd  |
c           %--------------------------%
c
            print *, ' '
            print *, ' Error with _naupd info = ',info
            print *, ' Check the documentation of _naupd '
            print *, ' '
c
         else
c
            call cneupd (rvec, howmny , select, d, z, ldz, sigma,
     &                   workev, bmat, n, which, nev, tol,
     &                   resid, ncv, v, ldv, iparam, ipntr, workd,
     &                   workl, lworkl, rwork, info)
c
            if ( info .ne. 0) then
c
c              %------------------------------------%
c              | Check the documentation of cneupd. |
c              %------------------------------------%
c
               print *, ' '
               print *, ' Error with _neupd = ', info
               print *, ' Check the documentation of _neupd '
               print *, ' '
c
            endif
c
         end if
c
         go to 9000
c
      end if
c
c     %----------------------------------------%
c     | L O O P  B A C K to call cnaupd again. |
c     %----------------------------------------%
c
      go to 40
c
 9000 continue
c
      end


program trfst1
  use fstpack
  implicit none

  integer, parameter :: l = 128
  real :: cr, r(l), s(l)
  complex, allocatable :: w(:, :)
  integer :: c1, c2, err, n

  s = chirp()
  allocate(w(l/2+1, l))
  call system_clock(count_rate=cr)

  call system_clock(c1)
  call rfst1f(s, w, err)
  call system_clock(c2)
  print *, 'system_clock: ', (c2 - c1) / cr
  if(err /= 0) error stop
  call rfst1b(w, r, err)
  if(err /= 0) error stop
  do n = 1, l
    print '(F11.6,1X,F11.6,1X,F11.6)', s(n), r(n), abs(s(n) - r(n))
  end do

contains
  function chirp() result(s)
    real, parameter :: pi = 4.0 * atan(1.0)
    real :: s(0:l-1)
    integer :: t

    do concurrent(t = 0:63)
      s(t) = cos(2. * pi * t * 6. / 128.)
    end do
    do concurrent(t = 64:127)
      s(t) = cos(2. * pi * t * 25. / 128.)
    end do
    do concurrent(t = 20:29)
      s(t) = s(t) + .5 * cos(2. * pi * t * 52. / 128.)
    end do
  end function
end program


      SUBROUTINE SETUP
*
*
*       Generation of initial coordinates & velocities.
*       -----------------------------------------------
*
      INCLUDE 'common6.h'
      REAL*8  A(8)
      REAL*8  RAN2
*
*
*       Choose between uniform density and Plummer model.
      KDUM = IDUM1
      IF (KZ(5).GT.0) GO TO 20
*
*       Set up a uniform spherical system.
      DO 10 I = 1,N
    1     A(1) = 0.0D0
          DO 2 K = 1,3
              A(K+1) = 2.0*RAN2(KDUM) - 1.0
              A(1) = A(1) + A(K+1)**2
    2     CONTINUE
          IF (A(1).GT.1.0) GO TO 1
*
    4     A(5) = 0.0D0
          DO 5 K = 1,3
              A(K+5) = 2.0*RAN2(KDUM) - 1.0
              A(5) = A(5) + A(K+5)**2
    5     CONTINUE
          IF (A(5).GT.1.0) GO TO 4
*
          DO 8 K = 1,3
*             X(K,I) = A(1)*A(K+1)
*       Density proportional to 1/R**2.
              X(K,I) = A(K+1)
*       Constant density.
              XDOT(K,I) = A(K+5)
*       Isotropic velocities (magnitude randomized; no radial dependence).
    8     CONTINUE
   10 CONTINUE
*
      GO TO 60
*
*       Initialize centre of mass terms.
   20 DO 25 K = 1,3
          CMR(K) = 0.0D0
          CMRDOT(K) = 0.0D0
   25 CONTINUE
*
*       Generate initial conditions from Plummer model (A & A 37, 183).
      DO 40 I = 1,N
   30     A(1) = RAN2(KDUM)
          IF (A(1).LT.1.0D-10) GO TO 30
          RI = (A(1)**(-0.6666667) - 1.0)**(-0.5)
*       Reject distant particles.
          IF (RI.GT.10.0) GO TO 30
*
          A(2) = RAN2(KDUM)
          A(3) = RAN2(KDUM)
          X(3,I) = (1.0 - 2.0*A(2))*RI
          X(1,I) = SQRT(RI**2 - X(3,I)**2)*COS(TWOPI*A(3))
          X(2,I) = SQRT(RI**2 - X(3,I)**2)*SIN(TWOPI*A(3))
   32     A(4) = RAN2(KDUM)
          A(5) = RAN2(KDUM)
          A(6) = A(4)**2*(1.0 - A(4)**2)**3.5
          IF (0.1*A(5).GT.A(6)) GO TO 32
*
          A(8) = A(4)*SQRT(2.0)/(1.0 + RI**2)**0.25
          A(6) = RAN2(KDUM)
          A(7) = RAN2(KDUM)
          XDOT(3,I) = (1.0 - 2.0*A(6))*A(8)
          XDOT(1,I) = SQRT(A(8)**2 - XDOT(3,I)**2)*COS(TWOPI*A(7))
          XDOT(2,I) = SQRT(A(8)**2 - XDOT(3,I)**2)*SIN(TWOPI*A(7))
*
*       Accumulate c.m. terms.
          DO 35 K = 1,3
              CMR(K) = CMR(K) + BODY(I)*X(K,I)
              CMRDOT(K) = CMRDOT(K) + BODY(I)*XDOT(K,I)
   35     CONTINUE
   40 CONTINUE
*
*       Scale coordinates & velocities to analytical expectation values.
      SX = 1.5*TWOPI/16.0
      SV = SQRT(ZMASS/SX)
      DO 50 I = 1,N
          DO 45 K = 1,3
              X(K,I) = X(K,I) - CMR(K)/ZMASS
              XDOT(K,I) = XDOT(K,I) - CMRDOT(K)/ZMASS
              X(K,I) = SX*X(K,I)
              XDOT(K,I) = SV*XDOT(K,I)
   45     CONTINUE
   50 CONTINUE
*
*
*       Save random number sequence in COMMON for future use.
   60 IDUM1 = KDUM
*
      RETURN
*
      END


program problem17
  implicit none
  integer :: i,s=0

  do i=1,1000
     s=s+letters(i)
  end do

  print *, s

contains
  pure function letters(starting_n)
    integer, intent(in) :: starting_n
    integer             :: n,letters

    n=starting_n
    letters=0

1   select case (n)
    case (1:2,6,10)
       letters=letters+3 ! one, two, six, ten
    case (4:5,9)
       letters=letters+4 ! four, five, nine
    case (3,7:8)
       letters=letters+5 ! three, seven, eight
    case (11:12)
       letters=letters+6 ! eleven, twelve
    case (13:14)
       letters=letters+8 ! thirteen, fourteen
    case (15:16)
       letters=letters+7 ! fifteen, sixteen
    case (17)
       letters=letters+9 ! seventeen
    case (18:19)
       letters=letters+8 ! eighteen, nineteen
    case (20:29)
       letters=letters+6 ! twenty
       n=n-20
       go to 1
    case (30:39)
       letters=letters+6 ! thirty
       n=n-30
       go to 1
    case (40:49)
       letters=letters+5 ! forty
       n=n-40
       go to 1
    case (50:59)
       letters=letters+5 ! fifty
       n=n-50
       go to 1
    case (60:69)
       letters=letters+5 ! sixty
       n=n-60
       go to 1
    case (70:79)
       letters=letters+7 ! seventy
       n=n-70
       go to 1
    case (80:89)
       letters=letters+6 ! eighty
       n=n-80
       go to 1
    case (90:99)
       letters=letters+6 ! ninety
       n=n-90
       go to 1
    case (100:999)
       letters=letters+7 ! hundred
       select case (n / 100)
       case (1:2,6)
          letters=letters+3 ! one, two, six
       case (3,7:8)
          letters=letters+5 ! three, seven, eight
       case (4:5,9)
          letters=letters+4 ! four, five, nine
       end select
       n=mod(n,100)
       if (n /= 0) then
          letters=letters+3 ! and
          go to 1
       end if
    case (1000)
       letters=letters+11 ! one thousand
    end select

  end function letters

end program problem17


c { dg-do run }
c Fix PR libgfortran/24313
      complex x, y
      complex z
      z = cmplx(0.707106, -0.707106)
      x = cmplx(0.0,-1.0)
      y = sqrt(x)
      if (abs(y - z) / abs(z) > 1.e-4) call abort

      x = cmplx(tiny(1.),-1.0)
      y = sqrt(x)
      if (abs(y - z) / abs(z) > 1.e-4) call abort

      x = cmplx(-tiny(1.),-1.0)
      y = sqrt(x)
      if (abs(y - z) / abs(z) > 1.e-4) call abort

      end


module t_position
    implicit none

    type position
        integer :: x
        integer :: y
        integer :: z
    end type

    interface operator (+)
        module procedure add_position
    end interface

contains
    type(position) function add_position(a, b)
        type(position), intent(in) :: a, b

        add_position = position(a%x+b%x,&
            a%y+b%y,a%z+b%z)
    end function
end module

program ch2401
    ! Overloading the Addition (+) Operator
    use t_position
    implicit none

    type(position) :: a, b, c

    a = position(10,10,10)
    b = position(20,20,20)
    c = a+b
    print *, a
    print *, b
    print *, c
end program


C
C Perfectly-stirred reactor model (either IC engine or Constant T,P)
C Uses DASSL to integrate DAE system
C
C Paul Yelvington, MIT (5 April 04)
C
C System of Equations:
C
C	For IC engine model (adiabatic, variable-volume reactor),
C
C     dY/dt = V*WDOT*WT , K=1,NSPC
C     Cv*dT/dt = -P*dV/dt - V*SUM(E*WDOT*WT)
C     RHO*R/WTM*T = P
C     VCYL = VCYL(t),  V = VCYL(t)/M
C
C	For Constant T,P reactor,
C
C     dY/dt = V*WDOT*WT , K=1,NSPC
C
C
      SUBROUTINE REACTOR(NEQ,LIN,LPAR,LDAT,LOUT,RWORK,IWORK,
     >                       CWORK,Q,DQ,KSYM,REAC,LRDSL,LIDSL,XML)

      IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)

      DIMENSION RWORK(*), IWORK(*), Q(*), DQ(*), REAC(*)
      DIMENSION ATOL(1), RTOL(1), INFO(25)
      CHARACTER CWORK(*)*(*), KSYM(*)*(*), XERN*8
      LOGICAL KERR, XML

      EXTERNAL RICEN,RCNTP

      COMMON /IPOINT/ NIPAR,NICK,NIDSL
      COMMON /RPOINT/ NRPAR,NREAC,NWT,NU,NWDOT,NCVMS,NC,NQ,NDQ,NRCK,
     >                NRDSL
      COMMON /ICONS/  NSPC,NRXN,NVAR,NT,NY,NP
      COMMON /RCONS/  R,SPDRAD,THETAZERO,RMASS
      COMMON /INPUTS/ RTOL,ATOL,TEMP,PRES,TZERO,TSTOP,SPD,CADZERO,
     >                RC,RLA,VC

      DATA  KERR/.FALSE./, INFO /25*0/

C     Get species names and molecular weights
      CALL CKWT(IWORK(NICK), RWORK(NRCK), RWORK(NWT))
      CALL CKSYMS(CWORK, LOUT, KSYM, KERR)
      IF (KERR) THEN
		CALL ERRORXML(LDAT,'Error reading species names.')
		STOP
	ENDIF

C     Read keyword or xml input file (reactor.inp or reactorInput.xml)
	ICASE = 0
	IF (XML) THEN
		CALL READXML (NSPC,KSYM,LIN,LOUT,REAC,KERR,ICASE)
	ELSE
		CALL REDKEY (NSPC,KSYM,LIN,LOUT,REAC,KERR,ICASE)
	ENDIF

      IF (KERR) THEN
		CALL ERRORXML(LDAT,'Error reading input file.')
		STOP
	ENDIF

      CLOSE(LIN)

C     Read keyword input for IC engine parameters (parameter.inp)
	IF(ICASE==1) THEN
		CALL REDKEY (NSPC,KSYM,LPAR,LOUT,REAC,KERR,ICASE)
		IF (KERR) THEN
			CALL ERRORXML(LDAT,'Error reading parameters file.')
			STOP
		ENDIF
		CLOSE(LPAR)
	ENDIF

C     Other parameters
      T    = TZERO                      ! Start time for simulation [s]
C      DELT = (TSTOP-TZERO)/10.0       ! Time-step for printout [s]

      R    = 8.314D0                    ! Universal gas constant [m3*Pa/mol-K]
      PI   = 3.14159                    ! Pi

      SPDRAD    = SPD*2.0*PI/60.0       ! Engine speed [radian/sec]
      THETAZERO = CADZERO*2.0*PI/360.0  ! Initial crank angle [radian]

C     Parameters for DASSL
      INFO(3) = 0             ! "1" sets intermediate output mode

C *** Set up consistent initial conditions

C     Temperature, Mass Fractions, and Pressure
      Q(NT) = TEMP   ! [K]
      Q(NP) = PRES   ! [Pa]
      CALL CKCTY(REAC,IWORK(NICK),RWORK(NRCK),Q(NY)) ! convert [mol/cm3] to Yk

	IF (ICASE==1) THEN ! IC engine
C		Calculate cylinder volume and its derivative
		CALL VOLUME(T,VCYL,DVCYLDT)

C		Calculate initial mass in cylinder
		CALL CKMMWY(Q(NY),IWORK(NICK),RWORK(NRCK),WTM)
		WTM = WTM*1.D-3                ! [kg/mol]
		RMASS = PRES*VCYL*WTM/(R*TEMP) ! [kg]

C		Temperature and Mass Fractions Derivatives
		CALL FUNZP(T,Q,DQ,RWORK,IWORK)

C		Pressure Derivative (algebraic equation)
		DQ(NP) = Q(NP)*(DQ(NT)/Q(NT) - DVCYLDT/VCYL)

	ELSEIF (ICASE==2) THEN ! Constant T,P
		CALL RCNTP(T,Q(NY),DQ(NY),DQ(NY),IRES,RWORK,IWORK)
	ELSE
		CALL ERRORXML(LDAT,'Problem keyword not found.')
		STOP
	ENDIF

C     Print page headings
C      WRITE(LOUT,*)
C      WRITE(LOUT,7100) (KSYM(K)(:10), K=1,NSPC)

C *** MAIN LOOP

C 10   CONTINUE

C *** Print out solution
C      CAD = CADZERO + T*SPD*6.0  ! [Degrees]

C      WRITE(LOUT, 7101) T, CAD, Q(NT), Q(NP)*1.0D-5,
C     >     (Q(NY+K-1), K=1,NSPC)

C *** Increment time and call the integrator

C      TOUT = T+DELT

 15	CONTINUE

C	IC Engine Model
	IF (ICASE==1) THEN
		CALL DDASSL(RICEN, NEQ, T, Q, DQ, TSTOP, INFO,
     >            RTOL, ATOL, IDID, RWORK(NRDSL), LRDSL, IWORK(NIDSL),
     >            LIDSL, RWORK, IWORK, JAC)
C	Constant T and P Model
	ELSEIF (ICASE==2) THEN
		CALL DDASSL(RCNTP, NSPC, T, Q(NY), DQ(NY), TSTOP, INFO,
     >            RTOL, ATOL, IDID, RWORK(NRDSL), LRDSL, IWORK(NIDSL),
     >            LIDSL, RWORK, IWORK, JAC)
	ENDIF

C     Print error message from DASSL
      IF (IDID.LT.0) THEN
         IF (IDID.EQ.-1) THEN
            INFO(1) = 1
            GOTO 15
         ELSE
            WRITE (XERN, '(I8)') IDID
            CALL ERRORXML(LDAT,'DASSL ERROR: IDID = ' // XERN)
            STOP
         END IF
      END IF

      IF (IDID.EQ.1) GO TO 15

C     Exit condition
C      IF (TOUT.LT.TSTOP*0.999) GO TO 10

C *** Print DASSL statistics
      CALL CPUTIM(TIMER)

      WRITE(LOUT,*)
      WRITE(LOUT,*) 'CPU Time (sec):',TIMER
      WRITE(LOUT,*)
      WRITE(LOUT,*) 'Number of steps: ',IWORK(NIDSL+10)
      WRITE(LOUT,*) 'Number of function evaluations: ',IWORK(NIDSL+11)
      WRITE(LOUT,*) 'Number of Jacobian evaluations: ',IWORK(NIDSL+12)
      WRITE(LOUT,*) 'Number of converg. test failures: ',IWORK(NIDSL+14)
      WRITE(LOUT,*) 'Number of error test failures: ',IWORK(NIDSL+13)
      WRITE(LOUT,*) 'SUCCESSFULLY COMPLETED RUN.'
      WRITE(LOUT,*)

C *** Write reactorOutput.xml or reactor.out file to pass back to RMG
      PCGS = 10.0D0*Q(NP) ! convert Pa to dyne/cm2
      CALL CKYTCP(PCGS,Q(NT),Q(NY),IWORK(NICK),RWORK(NRCK),RWORK(NC)) ! get [Xk]
      CALL CKWC(Q(NT),RWORK(NC),IWORK(NICK),RWORK(NRCK),RWORK(NWDOT)) ! get wdot

	IF (XML) THEN
		WRITE(LDAT, '(A)') '<?xml version="1.0" standalone="no"?>'
		WRITE(LDAT, '(A)') '<!DOCTYPE reactoroutput SYSTEM ' //
     >         '"./documentTypeDefinitions/reactorOutput.dtd">'
		WRITE(LDAT, '(A)') '<reactoroutput>'
		WRITE(LDAT, '(A)') ''
		WRITE(LDAT, '(A)') '<title>Reactor Output File</title>'
		WRITE(LDAT, '(2A)') '<description>External-solver-generated ',
     >       'file that returns the mixture state to RMG</description>'
		WRITE(LDAT, '(A)') ''
		WRITE(LDAT, '(A)') '<returnmessage>' //
     >                    'SUCCESSFULLY COMPLETED RUN.</returnmessage>'
		WRITE(LDAT, '(A)') '<outputvalues>'
		WRITE(LDAT, 7103) '<time units="sec">',T,'</time>'
		WRITE(LDAT, '(A)') '<systemstate>'
		WRITE(LDAT, 7103)
     >                 '<temperature units="K">',Q(NT),'</temperature>'
		WRITE(LDAT, 7103) '<pressure units="Pa">',Q(NP),'</pressure>'
		DO K=1,NSPC
			NCHARS = ILASCH(KSYM(K))
			WRITE(LDAT,7104) '<amount units="molPerCm3" speciesid="',
     >               KSYM(K)(:NCHARS), '">', RWORK(NC+K-1), '</amount>'
		ENDDO
		DO K=1,NSPC
			NCHARS = ILASCH(KSYM(K))
			WRITE(LDAT,7104) '<flux units="molPerCm3-Sec" speciesid="',
     >               KSYM(K)(:NCHARS), '">', RWORK(NWDOT+K-1), '</flux>'
		ENDDO
		WRITE(LDAT, '(A)') '</systemstate>'
		WRITE(LDAT, '(A)') '</outputvalues>'
		WRITE(LDAT, '(A)') '</reactoroutput>'
	ELSE
		WRITE(LDAT, '(A)') '// units are sec, K, Pa, mol/cm3'
		WRITE(LDAT,'(A,14X,E16.8E3)') 'time', T
		WRITE(LDAT,'(A,14X,E16.8E3)') 'temp', Q(NT)
		WRITE(LDAT,'(A,14X,E16.8E3)') 'pres', Q(NP)
		DO K=1,NSPC
			WRITE(LDAT,7102) KSYM(K)(:16), RWORK(NC+K-1)
		ENDDO
	ENDIF

C FORMATS
 7100 FORMAT (2X, 'T(sec)', 8X, 'CAD', 11X, 'TMP(K)', 8X,
     >     'P(bar)', 4X, 1100(2X,A12))
 7101 FORMAT (1100(1X,E13.5E3))
 7102 FORMAT (A16,2X, E16.8E3)
 7103 FORMAT (A,1X,E16.8E3,1X,A)
 7104 FORMAT (3A,1X,E16.8E3,1X,A)

      RETURN
      END
C ***
C ***
C ***
C ***
	SUBROUTINE ERRORXML(LDAT,ERRMSG)
C	Write an error message in XML format for RMG

      IMPLICIT NONE
	INTEGER LDAT,NCHARS,ILASCH
	CHARACTER ERRMSG*(*)

	NCHARS = ILASCH(ERRMSG)

	WRITE(LDAT, '(A)') '<?xml version="1.0" standalone="no"?>'
		WRITE(LDAT, '(A)') '<!DOCTYPE reactoroutput SYSTEM ' //
     >         '"./documentTypeDefinitions/reactorOutput.dtd">'
	WRITE(LDAT, '(A)') '<reactoroutput>'
	WRITE(LDAT, '(A)') ''
	WRITE(LDAT, '(A)') '<title>Reactor Output File</title>'
	WRITE(LDAT, '(2A)') '<description>External-solver-generated ',
     >       'file that returns  the mixture state to RMG</description>'
	WRITE(LDAT, '(A)') ''
	WRITE(LDAT, '(A)') '<returnmessage>' // ERRMSG(:NCHARS) //
     >                   '</returnmessage>'
	WRITE(LDAT, '(A)') '</reactoroutput>'

	RETURN
	END


program N-cuerpos
real::dE,E,Er,dist,G,vel,epsi
real,allocatable,dimension(:)::m,r,v,a
!real,allocatable,dimension(:,:)::a
integer::i,j

!valores de constante( G constante universal, n numero de particulas)
G=
n=
epsi=
dt=

allocate(a(n),v(i),m(i),r(i))

!calculo de la matriz aceleracion
!duda si poner m(i) o m(j) cual es la que no es de la particula??
a=0.0d1
do  i=1,n
if (i.ne.j) then
do  j=1,n
a(i)=-((G*m(j))/((abs(r(i)-r(j))**2)+epsi))

!energia
dist=0
vel=0
do  i=1,n
vel=m(i)*(v(i)**2)+vel
if (i.ne.j) then
do  j=i,n
dist=dist+((abs(r(i)-r(j)))/(m(i)*m(j)*G))
end do
end if
end do
E=(1/2.0)*(vel)-(1/dist)

!error relativo
Er=dE/E
write(10,*) Er


       SUBROUTINE R2FFT(C,ID,NM,NN,WM,WN,ISIG,IORD,IWORK,IERR)
****PURPOSE:
*       THIS ROUTINE PERFORMS A 2-DIMENSIONAL REAL FOURIER TRANSFORM,
*       OF ORDER NM*NN.
****USAGE:
*       THE USER IS EXPECTED TO PROVIDE THE DATA IN A 2-DIMENSIONAL
*       REAL ARRAY C, DIMENSIONED IN THE CALLING PROGRAM C(ID,NN)
*       AND EQUIVALENCED TO A COMPLEX ARRAY CCOM(ID/2,NN).
*       WHEN A DIRECT TRASNFORM IS PERFORMED, HALF OF THE OUTPUT
*       COEFFICIENTS ARE CONTAINED IN CCOM(I,J) AS FOLLOWS
*        X(I,J)= CCOM(I,J) WITH I=1,(NM/2+1) AND J=1,NN
*       THE REMAINING ONES ARE OBTAINED EXPLOITING THE CONJUGATED
*       SYMMETRY RELATION
*        X(I,J) = CONJG(CCOM(NM-I+2,NN-J+2))
*       WITH I=NM/2+2,NM  AND  J=1,NN
*       NM (ACTUAL FIRST DIMENSION OF DATA) MUST BE AN EVEN NUMBER;
*       ID (DECLARED FIRST DIMENSION) MUST BE GR. OR EQ. TO NM+2.
*       THE ELEMENTS C(K,*), NM<K<=ID MUST BE ZEROED. THE ROUTINE IS
*       INTENDED FOR REPEATED USAGE, THUS SEPARATE SET-UP AND
*       OPERATING CALLS ARE AVAILABLE : THE USER SHOULD ALWAYS PERFORM
*       A SET-UP CALL ( ISIG=0 ) PASSING THE CHOSEN PARAMETERS, BEFORE
*       PERFORMING THE ACTUAL TRANSFORM ( ISIG= +1 OR -1 ); THE USER CAN
*       CHOOSE WHETHER TO OBTAIN THE RESULTS OF THE DIRECT TRANSFORM
*       IN NATURAL ORDER (ISIG=-1,IORD=1) OR LEAVE THEM IN THE
*       BIT-REVERSED  ORDER( ISIG=-1,IORD=0); THIS CHOICE SAVES
*       SOME COMPUTER TIME, AND IT IS RECOMMENDED IN CASES DISCUSSED
*       IN THE LONG WRITE-UP. ANALOGOUSLY, THE INVERSE TRANSFORM ACCEPTS
*       INPUT ( PLEASE NOTE| ) DATA IN NATURAL ORDER ( ISIG=1,IORD=1),
*       OR DATA ALREADY SUBJECTED TO A BIT-REVERSAL PERMUTATION( ISIG=1
*       IORD=0 ).
****PARAMETERS :
*       INPUT :
*       C : ARRAY TO BE TRANSFORMED; DECLARED REAL C(ID,NN) IN THE
*           CALLING PROGRAM;
*       ID : FIRST DIMENSION OF C IN THE CALLING PROGRAM
*            IT MUST BE AN EVEN NUMBER EQUAL TO NM+2.
*       ISIG : OPTION FLAG : ISIG=0 : SET-UP RUN, C NOT USED
*                            ISIG=-1: DIRECT TRANSFORM
*                            ISIG=+1: INVERSE TRANSFORM
*       WM,WN : INTEGER ARRAYS , USED TO HOST TABLES FOR THE TRANSFORM;
*               DIMENSIONED IN THE CALLING PROGRAM IN THIS WAY :
*               WM : AT LEAST (6*NM+14)
*               WN : AT LEAST (4*NN+14)
*               IF ISIG.NE.0 ,THEY ARE ASSUMED TO HAVE BEEN SET
*                BY A PREVIOUS CALL WITH ISIG=0 AND
*               ALL THE OTHER ARGUMENTS UNCHANGED, AND NEVER HAVE BEEN
*               MODIFIED SINCE THEN;
*               IF NM=NN, WM AND WN DO NOT NEED TO BE DISTINCT;
*       NM : ORDER OF THE TRANSFORM ALONG THE COLUMNS OF C
*       NN : ORDER OF THE TRANSFORM ALONG THE ROWS OF C
*       IORD : OPTION FLAG : =1 : OUTPUT IN NATURAL ORDER (ISIG=-1)
*                                 INPUT IN NATURAL ORDER  (ISIG=+1)
*                            =0 : OUTPUT IN BIT-REVERSED ORDER(ISIG=-1)
*                                 INPUT IN BIT-REVERSED ORDER(ISIG=+1)
*                                 WARNING:THE FIRST DIMENSION IS ORDERED
*                                 IN ANY CASE BECAUSE OF POST-PROCESSING
*                                 (FOR DIRECT) AND PRE-PROCESSING FOR
*                                 INVERSE REAL TRANSFORMS
*       IWORK : INTEGER ARRAY, USED AS WORK AREA FOR REORDERING IF IORD=
*               1, MUST BE AT LEAST MAX(NM,NN) WORDS LONG.
*
****OUTPUT :
*       C : TRANSFORMED ARRAY
*       WM, WN : ONLY IF ISIG=0, WM AND WN ARE FILLED WITH THE
*               APPROPRIATE  TABLES
*       IWORK : UNDEFINED
*       IERR  : ERROR CODE : =0 : SUCCESSFUL
*                            =1 : WRONG ID PARAMETER
*                            =2 : PRIME FACTORS DIFFERENT FROM 2,3,5
*                                 ARE PRESENT IN DATA DIMENSIONS
*                            =3 : TABLES NOT CORRECTLY INITIALIZED
*                            =4 : FIRST DIMENSION IS AN ODD NUMBER
      COMPLEX C(*)
      INTEGER WM(-14:*),WN(-14:*)
      INTEGER IWORK(*)
*
      INTEGER IDERR,FACERR,TBERR,ODDERR
      PARAMETER (IDERR=1,FACERR=2,TBERR=3,ODDERR=4)
*
      IF(ID.LT.NM+2)THEN
        IERR=IDERR
        RETURN
      ENDIF
      NM1=NM/2
      IF(NM1*2.NE.NM)THEN
        IERR=ODDERR
        RETURN
      ENDIF
      IERR=0
*
      IF(ISIG.EQ.0) THEN
        CALL MFFTRP(NM,WM(4*NM))
        CALL MFFTP(NM1,WM,0,IERR)
        IF(IERR.NE.0)RETURN
        IF(NN.NE.NM1) THEN
          CALL MFFTP(NN,WN,0,IERR)
          IF(IERR.NE.0)RETURN
        ELSE
          CALL MFFTZ0(WM,1,4*NM1+14,WN,1)
        ENDIF
        RETURN
      ELSE  IF(ISIG.GT.0) THEN

        IF(IORD.NE.0) THEN
          CALL MFFTOV(C,ID/2,1,NN,NM1+1,WN(3*NN),IWORK)
        ENDIF
        CALL MFFTIV(C,ID/2,1,NN,NM1+1,WN,IERR)
        IF(IERR.NE.0)RETURN
        CALL MFFTRI(C,1,ID/2,NM1,NN,WM(4*NM))
        CALL MFFTOV(C,1,ID/2,NM1,NN,WM(3*NM1),IWORK)
        CALL MFFTIV(C,1,ID/2,NM1,NN,WM,IERR)
        IF(IERR.NE.0)RETURN

      ELSE
        CALL MFFTDV(C,1,ID/2,NM1,NN,WM,IERR)
        IF(IERR.NE.0)RETURN
        CALL MFFTOV(C,1,ID/2,NM1,NN,WM(NM1*2),IWORK)
        CALL MFFTRD(C,1,ID/2,NM1,NN,WM(4*NM))
        CALL MFFTDV(C,ID/2,1,NN,NM1+1,WN,IERR)
        IF(IERR.NE.0)RETURN

        IF(IORD.NE.0) THEN
          CALL MFFTOV(C,ID/2,1,NN,NM1+1,WN(NN*2),IWORK)
        ENDIF
*
      ENDIF
*
      END


      real*8 function tdet(a,n,ndim)
      use mathfun, only:p2h
      implicit none
      integer*4 ,intent(in)::n,ndim
      integer*4 i,j,k
      real*8 ,intent(inout)::a(ndim,n)
      real*8 d,di,p,x,u
      d=1.d0
      do i=1,n-1
        di=a(i,i)
        do j=i+1,n
          if(a(j,i) .ne. 0.d0)then
            if(di .eq. 0.d0)then
              do k=i+1,n
                x=a(j,k)
                a(j,k)=a(i,k)
                a(i,k)=x
              enddo
              di=a(j,i)
            else
              p=a(j,i)/di
c              u=1.d0/sqrt(1.d0+p**2)
              u=1.d0/p2h(p)
              do k=i+1,n
                x=a(j,k)
                a(j,k)=(x-p*a(i,k))*u
                a(i,k)=(a(i,k)+p*x)*u
              enddo
              di=(di+p*a(j,i))*u
            endif
          endif
        enddo
        d=d*di
        if(d .eq. 0.d0)then
          tdet=0.d0
          return
        endif
      enddo
      tdet=d*a(n,n)
      return
      end

      complex*16 function tcdet(a,n,ndim)
      implicit none
      integer*4 ,intent(in)::n,ndim
      integer*4 i,j,k
      real*8 u
      complex*16 ,intent(inout)::a(ndim,n)
      complex*16 d,di,p,x,pc
      d=(1.d0,0.d0)
      do i=1,n-1
        di=a(i,i)
        do j=i+1,n
          if(a(j,i) .ne. (0.d0,0.d0))then
            if(di .eq. (0.d0,0.d0))then
              do k=i+1,n
                x=a(j,k)
                a(j,k)=a(i,k)
                a(i,k)=x
              enddo
              di=a(j,i)
            else
              p=a(j,i)/di
              pc=conjg(p)
              u=1.d0/sqrt(1.d0+dble(p*pc))
              do k=i+1,n
                x=a(j,k)
                a(j,k)=(x-p*a(i,k))*u
                a(i,k)=(a(i,k)+pc*x)*u
              enddo
              di=(di+pc*a(j,i))*u
            endif
          endif
        enddo
        d=d*di
        if(d .eq. 0.d0)then
          tcdet=0.d0
          return
        endif
      enddo
      tcdet=d*a(n,n)
      return
      end


      subroutine sq_dailycn

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    Calculates curve number for the day in the HRU

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    smx(:)      |none          |retention coefficient for cn method based on
!!                               |soil moisture
!!    wrt(1,:)    |none          |1st shape parameter for calculation of
!!                               |water retention
!!    wrt(2,:)    |none          |2nd shape parameter for calculation of
!!                               |water retention
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    cnday(:)    |none          |curve number for current day, HRU and at
!!                               |current soil moisture
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Exp

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use basin_module
      use hru_module, only : cnday, wrt, smx, ihru
      use soil_module

      implicit none

      integer :: icn     !none          |counter
      integer :: j       !none          |HRU number
      real :: r2         !none          |retention parameter in CN equation
      real :: sw_fac     !none          |variable used to store intermediate value of soil water factor

      j = ihru

      sw_fac = wrt(1,j) - wrt(2,j) * soil(j)%sw
      if (sw_fac < -20.) sw_fac = -20.
      if (sw_fac > 20.) sw_fac = 20.

      !! traditional CN method (function of soil water)
      if ((soil(j)%sw + Exp(sw_fac)) > 0.001) then
        r2 = smx(j) * (1. - soil(j)%sw / (soil(j)%sw + Exp(sw_fac)))
      else
        r2 = smx(j)
      end if

      if (soil(j)%phys(2)%tmp <= 0.) r2 = smx(j) * (1. - Exp(- bsn_prm%cn_froz * r2))
      r2 = Max(3.,r2)

      cnday(j) = 25400. / (r2 + 254.)

      return
      end subroutine sq_dailycn


	FUNCTION ZPADC(F)
C
C	THIS FUNCTION RETURNS THE GAIN OF THE DC CHANNEL OF THE WIND Z PREAMP
C	THE FUNCTION ITSELF RETURNS THE MAGNITUDE OF THE GAIN, AND THE PHASE
C	AND THE COMPLEX GAIN ARE RETURNED IN A COMMON BLOCK
C
C	TO BE CHANGED FOR Y,Z:  R11,R32,C27,R9,C9,R10
C	DONE AND TESTED
C
	COMMON /GAINBLK/ PHASE,CGAIN        		  ! PHASE IS IN RADIANS
C	COMMON /COMPBLK/ CVAR(5)
C
	COMPLEX CGAIN,Y1,Z1,Y2,Z2
	DATA R9,C9,R10,CINP /18.E6,84.E-12,2.E8,4.99E-12/
	DATA R33,C16 /2.2E+03,1.202E-9/
	DATA RCOMP,CCOMP /22.1E3,47.E-12/
	DATA R29 /22.1E3/
	DATA TWOPI /6.2831853/
C
C	C16 = 1.203E-9                             ! ADJUSTING EX
C	C9  = 23.6E-12                            ! ADJUSTING EX
C	CINP = 4.99E-12                          ! ADJUSTING EZ
C
C	C16 = CVAR(1)
C	C9 = CVAR(2)
C	CINP = CVAR(3)
C
	W = TWOPI*F
	CGAIN = 1.
C	DIVISION OF SIGNAL BEFORE FOLLOWER
	Y1 = CMPLX(1./R9,W*C9)
	Y2 = CMPLX(1./R10,W*CINP)
	Z1 = 1./Y1
	Z2 = 1./Y2
	CGAIN = CGAIN*Z2/(Z1+Z2)
C	EFFECT OF OUTPUT RC
	WC16 = 1./(W*C16)
C	PRINT*,'W,Z1,WC16',W,Z1,WC16
C	PRINT*,'F,CGAIN,PHASE
	CGAIN = CGAIN*CMPLX(0.,-WC16)/CMPLX(R33,-WC16)
C
C	EFFECT OF INPUT (211) BOARD
C
	Y1 = 1./R29 + CMPLX(0.,W*C16)
	CGAIN = CGAIN/(1. + R33*Y1)
C
	GNIP = AIMAG(CGAIN)
	GNRP = CGAIN
	PHASE = ATAN2(GNIP,GNRP)
	ZPADC = CABS(CGAIN)
	RETURN
	END


      SUBROUTINE MB04PB( N, ILO, A, LDA, QG, LDQG, CS, TAU, DWORK,
     $                   LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To reduce a Hamiltonian matrix,
C
C                   [  A   G  ]
C              H =  [       T ] ,
C                   [  Q  -A  ]
C
C     where A is an N-by-N matrix and G,Q are N-by-N symmetric matrices,
C     to Paige/Van Loan (PVL) form. That is, an orthogonal symplectic U
C     is computed so that
C
C               T       [  Aout   Gout  ]
C              U H U =  [             T ] ,
C                       [  Qout  -Aout  ]
C
C     where Aout is upper Hessenberg and Qout is diagonal.
C     Blocked version.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A.  N >= 0.
C
C     ILO     (input) INTEGER
C             It is assumed that A is already upper triangular and Q is
C             zero in rows and columns 1:ILO-1. ILO is normally set by a
C             previous call to MB04DD; otherwise it should be set to 1.
C             1 <= ILO <= N, if N > 0; ILO = 1, if N = 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the matrix Aout and, in the zero part of Aout,
C             information about the elementary reflectors used to
C             compute the PVL factorization.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     QG      (input/output) DOUBLE PRECISION array, dimension
C                            (LDQG,N+1)
C             On entry, the leading N-by-N+1 part of this array must
C             contain the lower triangular part of the matrix Q and
C             the upper triangular part of the matrix G.
C             On exit, the leading N-by-N+1 part of this array contains
C             the diagonal of the matrix Qout, the upper triangular part
C             of the matrix Gout and, in the zero parts of Qout,
C             information about the elementary reflectors used to
C             compute the PVL factorization.
C
C     LDQG    INTEGER
C             The leading dimension of the array QG.  LDQG >= MAX(1,N).
C
C     CS      (output) DOUBLE PRECISION array, dimension (2N-2)
C             On exit, the first 2N-2 elements of this array contain the
C             cosines and sines of the symplectic Givens rotations used
C             to compute the PVL factorization.
C
C     TAU     (output) DOUBLE PRECISION array, dimension (N-1)
C             On exit, the first N-1 elements of this array contain the
C             scalar factors of some of the elementary reflectors.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0,  DWORK(1)  returns the optimal
C             value of LDWORK, 8*N*NB + 3*NB, where NB is the optimal
C             block size determined by the function UE01MD.
C             On exit, if  INFO = -10,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= MAX(1,N-1).
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The matrix U is represented as a product of symplectic reflectors
C     and Givens rotations
C
C     U = diag( H(1),H(1) )     G(1)   diag( F(1),F(1) )
C         diag( H(2),H(2) )     G(2)   diag( F(2),F(2) )
C                                ....
C         diag( H(n-1),H(n-1) ) G(n-1) diag( F(n-1),F(n-1) ).
C
C     Each H(i) has the form
C
C           H(i) = I - tau * v * v'
C
C     where tau is a real scalar, and v is a real vector with
C     v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in
C     QG(i+2:n,i), and tau in QG(i+1,i).
C
C     Each F(i) has the form
C
C           F(i) = I - nu * w * w'
C
C     where nu is a real scalar, and w is a real vector with
C     w(1:i) = 0 and w(i+1) = 1; w(i+2:n) is stored on exit in
C     A(i+2:n,i), and nu in TAU(i).
C
C     Each G(i) is a Givens rotation acting on rows i+1 and n+i+1,
C     where the cosine is stored in CS(2*i-1) and the sine in
C     CS(2*i).
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires O(N**3) floating point operations and is
C     strongly backward stable.
C
C     REFERENCES
C
C     [1] C. F. VAN LOAN:
C         A symplectic method for approximating all the eigenvalues of
C         a Hamiltonian matrix.
C         Linear Algebra and its Applications, 61, pp. 233-251, 1984.
C
C     [2] D. KRESSNER:
C         Block algorithms for orthogonal symplectic factorizations.
C         BIT, 43 (4), pp. 775-790, 2003.
C
C     CONTRIBUTORS
C
C     D. Kressner (Technical Univ. Berlin, Germany) and
C     P. Benner (Technical Univ. Chemnitz, Germany), December 2003.
C
C     REVISIONS
C
C     V. Sima, Nov. 2008 (SLICOT version of the HAPACK routine DHAPVB).
C     V. Sima, Aug. 2011.
C
C     KEYWORDS
C
C     Elementary matrix operations, Hamiltonian matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           ILO, INFO, LDA, LDQG, LDWORK, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), CS(*), DWORK(*), QG(LDQG,*), TAU(*)
C     .. Local Scalars ..
      LOGICAL           LQUERY
      INTEGER           I, IB, IERR, MINWRK, NB, NBMIN, NH, NIB, NNB,
     $                  NX, PDW, PXA, PXG, PXQ, PYA, WRKOPT
C     .. External Functions ..
      INTEGER           UE01MD
      EXTERNAL          UE01MD
C     .. External Subroutines ..
      EXTERNAL          DGEHRD, DGEMM, DSYR2K, MB04PA, MB04PU, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, INT, MAX, MIN
C
C     .. Executable Statements ..
C
C     Check the scalar input parameters.
C
      INFO   = 0
      MINWRK = MAX( 1, N-1 )
      IF ( N.LT.0 ) THEN
         INFO = -1
      ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
         INFO = -2
      ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF ( LDQG.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE
         LQUERY = LDWORK.EQ.-1
         IF ( LDWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
            DWORK(1) = DBLE( MINWRK )
            INFO = -10
         ELSE
            IF ( N.EQ.0 ) THEN
               WRKOPT = ONE
            ELSE
               CALL DGEHRD( N, ILO, N, DWORK, N, DWORK, DWORK, -1,
     $                      INFO )
               WRKOPT = MAX( MINWRK, INT( DWORK(1) ) )
               NB     = INT( WRKOPT/N )
               WRKOPT = MAX( WRKOPT, 8*N*NB + 3*NB )
            END IF
            IF ( LQUERY ) THEN
               DWORK(1) = DBLE( WRKOPT )
               RETURN
            END IF
         END IF
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB04PB', -INFO )
         RETURN
      END IF
C
C     Set elements 1:ILO-1 of TAU and CS.
C
      DO 10 I = 1, ILO - 1
         TAU( I ) = ZERO
         CS(2*I-1) = ONE
         CS(2*I) = ZERO
   10 CONTINUE
C
C     Quick return if possible.
C
      IF ( N.LE.ILO ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Determine the block size.
C
      NH = N - ILO + 1
      NBMIN = 2
      IF ( NB.GT.1 .AND. NB.LT.NH ) THEN
C
C        Determine when to cross over from blocked to unblocked code.
C
         NX = MAX( NB, UE01MD( 3, 'MB04PB', ' ', N, ILO, -1 ) )
         IF ( NX.LT.NH ) THEN
C
C           Check whether workspace is large enough for blocked code.
C
            IF ( LDWORK.LT.WRKOPT ) THEN
C
C              Not enough workspace available. Determine minimum value
C              of NB, and reduce NB.
C
               NBMIN = MAX( 2, UE01MD( 2, 'MB04PB', ' ', N, ILO, -1 ) )
               NB = LDWORK / ( 8*N + 3 )
            END IF
         END IF
      END IF
C
      NNB = N*NB
      PXA = 1
      PYA = PXA + 2*NNB
      PXQ = PYA + 2*NNB
      PXG = PXQ + 2*NNB
      PDW = PXG + 2*NNB
C
      IF ( NB.LT.NBMIN .OR. NB.GE.NH ) THEN
C
C        Use unblocked code.
C
         I = ILO
C
      ELSE
         DO 20  I = ILO, N-NX-1, NB
            IB = MIN( NB, N-I )
            NIB = N*IB
C
C           Reduce rows and columns i:i+nb-1 to PVL form and return the
C           matrices XA, XG, XQ, and YA which are needed to update the
C           unreduced parts of the matrices.
C
            CALL MB04PA( .TRUE., N-I+1, I-1, IB, A(1,I), LDA, QG(1,I),
     $                   LDQG, DWORK(PXA), N, DWORK(PXG), N,
     $                   DWORK(PXQ), N, DWORK(PYA), N, CS(2*I-1),
     $                   TAU(I), DWORK(PDW) )
            IF ( N.GT.I+IB ) THEN
C
C              Update the submatrix A(1:n,i+ib+1:n).
C
               CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB,
     $                     IB, ONE, QG(I+IB+1,I), LDQG, DWORK(PXA+IB+1),
     $                     N, ONE, A(I+IB+1,I+IB+1), LDA )
               CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB,
     $                     IB, ONE, A(I+IB+1,I), LDA,
     $                     DWORK(PXA+NIB+IB+1), N, ONE,
     $                     A(I+IB+1,I+IB+1), LDA )
               CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB, IB,
     $                     ONE, DWORK(PYA), N, QG(I+IB+1,I), LDQG, ONE,
     $                     A(1,I+IB+1), LDA )
               CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB, IB,
     $                     ONE, DWORK(PYA+NIB), N, A(I+IB+1,I), LDA,
     $                     ONE, A(1,I+IB+1), LDA )
C
C              Update the submatrix Q(i+ib+1:n,i+ib+1:n).
C
               CALL DSYR2K( 'Lower', 'No Transpose', N-I-IB, IB, ONE,
     $                      DWORK(PXQ+IB+1), N, QG(I+IB+1,I), LDQG, ONE,
     $                      QG(I+IB+1,I+IB+1), LDQG )
               CALL DSYR2K( 'Lower', 'No Transpose', N-I-IB, IB, ONE,
     $                      DWORK(PXQ+NIB+IB+1), N, A(I+IB+1,I), LDA,
     $                      ONE, QG(I+IB+1,I+IB+1), LDQG )
C
C              Update the submatrix G(1:n,1:n).
C
               CALL DGEMM( 'No transpose', 'Transpose', I+IB, N-I-IB,
     $                     IB, ONE, DWORK(PXG), N, QG(I+IB+1,I), LDQG,
     $                     ONE, QG(1,I+IB+2), LDQG )
               CALL DGEMM( 'No transpose', 'Transpose', I+IB, N-I-IB,
     $                     IB, ONE, DWORK(PXG+NIB), N, A(I+IB+1,I), LDA,
     $                     ONE, QG(1,I+IB+2), LDQG )
               CALL DSYR2K( 'Upper', 'No Transpose', N-I-IB, IB, ONE,
     $                      DWORK(PXG+IB+I), N, QG(I+IB+1,I), LDQG, ONE,
     $                      QG(I+IB+1,I+IB+2), LDQG )
               CALL DSYR2K( 'Upper', 'No Transpose', N-I-IB, IB, ONE,
     $                      DWORK(PXG+NIB+IB+I), N, A(I+IB+1,I), LDA,
     $                      ONE, QG(I+IB+1,I+IB+2), LDQG )
            END IF
   20    CONTINUE
      END IF
C
C     Unblocked code to reduce the rest of the matrices.
C
      CALL MB04PU( N, I, A, LDA, QG, LDQG, CS, TAU, DWORK, LDWORK,
     $             IERR )
C
      DWORK( 1 ) = DBLE( WRKOPT )
C
      RETURN
C *** Last line of MB04PB ***
      END


      subroutine sblas2()
*
      CALL SGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX,
     $                   BETA, Y, INCY )
*
      CALL SGBMV ( TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX,
     $                   BETA, Y, INCY )
*
      CALL SSYMV ( UPLO, N, ALPHA, A, LDA, X, INCX,
     $                   BETA, Y, INCY )
*
      CALL SSBMV ( UPLO, N, K, ALPHA, A, LDA, X, INCX,
     $                   BETA, Y, INCY )
*
      CALL SSPMV ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )
*
      CALL STRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
*
      CALL STBMV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
*
      CALL STPMV ( UPLO, TRANS, DIAG, N, AP, X, INCX )
*
      CALL STRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
*
      CALL STBSV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
*
      CALL STPSV ( UPLO, TRANS, DIAG, N, AP, X, INCX )
*
      CALL SGER  ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
*
      CALL SSYR  ( UPLO, N, ALPHA, X, INCX, A, LDA )
*
      CALL SSPR  ( UPLO, N, ALPHA, X, INCX, AP )
*
      CALL SSYR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA )
*
      CALL SSPR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, AP )
*
      stop
      end


      double precision function f1(x,y)
      double precision, intent(in)  :: x, y
      !f1 = abs(cos(x + y) * log(y))
      f1 = sqrt(sqrt(x))/sqrt(y) + y/x
      return
      end function f1

      double precision function f2(x,y)
      double precision, intent(in)  :: x, y
      !f2 = sqrt(abs(sin(x + y) / y))
      f2 = sqrt(sqrt(x*y))/sqrt(y/x) + x/y
      return
      end function f2

      subroutine sub1(a,b,c,n)
      implicit none
      integer, intent(in)           :: n
      double precision, intent(in)  :: a(n), b(n)
      double precision, intent(out) :: c(n)
      double precision f1, f2
      integer i
      do i=1,n
         c(i) = f1(a(i),b(i)) + f2(a(i),b(i))
      enddo
      end subroutine sub1

      subroutine sub2(a,b,c,n)
      implicit none
      integer, intent(in)           :: n
      double precision, intent(in)  :: a(n), b(n)
      double precision, intent(out) :: c(n)
      double precision f1
      integer i
      do i=1,n
         c(i) = f1(b(i),a(i))
      enddo
      end subroutine sub2

      program intro
      implicit none
      character(len=32) :: arg
      integer i, n
      double precision, allocatable :: x(:), y (:), z(:), w(:)
      double precision elapsed_time, time

C     Get the array rank from command line
      call get_command_argument(1, arg)
      read(arg,*) n

C     Allocate arrays
      allocate(w(n), x(n), y(n), z(n))

C     Initialize the arrays x and y
      do i=1,n
         x(i) = i*1.1
         y(i) = i/3.3
      enddo

      call sub1(x,y,z,n)
      call sub1(y,x,z,n)
      call sub2(x,y,w,n)

C     Following code prevents earlier operations from being optimized
C     away since it leaves open the possibility that the array w and z
C     are used.

      if (z(1) == -1.0 .and. w(1) == -1.0) then
         open (3,file="wz.out",form="unformatted",access="sequential")
         write(3) w
         write(3) z
         close(3)
      endif

      deallocate(w,x,y,z)

      end program intro


!-------------------------------------------
module lp_lap
  implicit none
contains
!----------------------------------------------
  complex(c_double_complex) function slp_laplace(xm,y1,y2,hy,n) bind(c)
    use iso_c_binding
    implicit none

    real(c_double),intent(in) :: xm(2),y1(2),y2(2),hy,n(2)

    real(c_double) :: t(2), r1, r2
    real(c_double) :: rr1(2), rr2(2)
    real(c_double) :: uk1,uk2,uk3,uk4,uk5
    real(c_double) :: dnrm2 !blas
    real(c_double),parameter :: arctwopi = 0.159154943091895d0

    real(c_double) :: ym(2)

    ym = (y1 + y2)*0.5d0

    if(abs(xm(1)-ym(1))+abs(xm(2)-ym(2)) .lt. 1d-8) then
       slp_laplace = hy*(1d0-log(hy*0.5d0))*arctwopi
    else
       rr1 = xm - y1
       rr2 = xm - y2
       r1 = dnrm2(2, rr1(1), 1)
       r2 = dnrm2(2, rr2(1), 1)
       t(1) = -n(2)
       t(2) = n(1)

       uk1 = dot_product(rr1,n)
       uk2 = dot_product(rr1,t)
       uk3 = dot_product(rr2,n)
       uk4 = dot_product(rr2,t)
       uk5 = atan2(uk3,uk4)-atan2(uk1,uk2)
       slp_laplace = dcmplx((uk4*log(r2)-uk2*log(r1)+hy-uk1*uk5)*arctwopi, 0d0)
    end if

  end function slp_laplace
!----------------------------------------
  complex(c_double_complex) function dlp_laplace(xm,y1,y2,hy,n,exterior) bind(c)
    use iso_c_binding
    implicit none

    real(c_double),intent(in) :: xm(2),y1(2),y2(2),hy,n(2)
    integer(c_int),optional,intent(in) :: exterior

    real(c_double) :: t(2),r1,r2
    real(c_double) :: rr1(2), rr2(2)
    real(c_double) :: uk1,uk2,uk3,uk4,uk5
    real(c_double) :: dnrm2 !blas
    real(c_double),parameter :: arctwopi = 0.159154943091895d0

    real(c_double) :: ym(2)

    ym = (y1 + y2)*0.5d0

    if(abs(xm(1)-ym(1))+abs(xm(2)-ym(2)) .lt. 1d-8) then
       if(present(exterior)) then
          if(exterior == 0) dlp_laplace = dcmplx(0.5d0, 0d0)
          if(exterior == 1) dlp_laplace = dcmplx(-0.5d0, 0d0)
       else
          stop 'if(present(exterior)) is false in dlp_laplace'
       end if
    else
       rr1 = xm - y1
       rr2 = xm - y2
       r1 = dnrm2(2, rr1(1), 1)
       r2 = dnrm2(2, rr2(1), 1)
       t(1) = -n(2)
       t(2) = n(1)

       uk1 = dot_product(rr1, n)
       uk2 = dot_product(rr1, t)
       uk3 = dot_product(rr2, n)
       uk4 = dot_product(rr2, t)
       uk5 = atan2(uk3,uk4)-atan2(uk1,uk2)
       dlp_laplace = dcmplx(uk5*arctwopi, 0d0)
    end if

    return
  end function dlp_laplace
!----------------------------------------
end module lp_lap


! { dg-do run }
! { dg-options "-finit-derived -finit-integer=1" }
!
! Make sure -finit-derived works on class variables.
! Based on class_result_1.f03
!

module points_2i

  implicit none

  type point2i
      integer :: x, y
  end type

contains

 subroutine print( point )
   class(point2i) :: point
   write(*,'(2i4)') point%x, point%y
 end subroutine

 subroutine set_vector( point, rx, ry )
   class(point2i) :: point
   integer :: rx, ry
   point%x = rx
   point%y = ry
 end subroutine

 function add_vector( point, vector )
   class(point2i), intent(in)  :: point, vector
   class(point2i), allocatable :: add_vector
   allocate( add_vector )
   add_vector%x = point%x + vector%x
   add_vector%y = point%y + vector%y
 end function

end module

program init_flag_15

  use points_2i
  implicit none

  type(point2i), target   :: point_2i, vector_2i
  class(point2i), pointer :: point, vector
  type(point2i) :: vsum
  integer :: i

  point  => point_2i ! = (1, 1) due to -finit-integer
  vector => vector_2i
  call set_vector(vector, 2, 2)
  vsum = add_vector(point, vector)

  call print(point)
  call print(vector)
  call print(vsum)

  if (vsum%x .ne. 3 .or. vsum%y .ne. 3) then
    call abort()
  endif

end program


! { dg-do run }
! PR52012 - with realloc_lhs active(ie. default condition) the
! offset was wrongly calculated for a, after assignment.
!
! Reported by Reinhold Bader and Tobias Burnus  <burnus@gcc.gnu.org>
!
program gf
  implicit none
  real, allocatable :: a(:,:,:)
  real, parameter :: zero = 0.0, one = 1.0
  real :: b(3,4,5) = zero
  b(1,2,3) = one
  allocate (a(size (b, 3), size (b, 2), size (b, 1)))
  a = reshape (b, shape (a), order = [3, 2, 1])
  if (any (a(:, 2, 1) .ne. [zero, zero, one, zero, zero])) STOP 1
  if (a(3, 2, 1) /= one) STOP 1
  if (sum (abs (a)) /= one) STOP 2
end program


module sorting
use kinds, only: r_single,r_double,i_long,i_kind
public :: quicksort, isort
contains
SUBROUTINE quicksort(n,x,ind)

IMPLICIT NONE

REAL(r_single), INTENT(IN)  :: x(n)
INTEGER, INTENT(IN OUT)   :: ind(n)
INTEGER, INTENT(IN)    :: n

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

!                                                         ROBERT RENKA
!                                                 OAK RIDGE NATL. LAB.

!   THIS SUBROUTINE USES AN ORDER N*LOG(N) QUICK SORT TO SORT A REAL
! ARRAY X INTO INCREASING ORDER.  THE ALGORITHM IS AS FOLLOWS.  IND IS
! INITIALIZED TO THE ORDERED SEQUENCE OF INDICES 1,...,N, AND ALL INTERCHANGES
! ARE APPLIED TO IND.  X IS DIVIDED INTO TWO PORTIONS BY PICKING A CENTRAL
! ELEMENT T.  THE FIRST AND LAST ELEMENTS ARE COMPARED WITH T, AND
! INTERCHANGES ARE APPLIED AS NECESSARY SO THAT THE THREE VALUES ARE IN
! ASCENDING ORDER.  INTERCHANGES ARE THEN APPLIED SO THAT ALL ELEMENTS
! GREATER THAN T ARE IN THE UPPER PORTION OF THE ARRAY AND ALL ELEMENTS
! LESS THAN T ARE IN THE LOWER PORTION.  THE UPPER AND LOWER INDICES OF ONE
! OF THE PORTIONS ARE SAVED IN LOCAL ARRAYS, AND THE PROCESS IS REPEATED
! ITERATIVELY ON THE OTHER PORTION.  WHEN A PORTION IS COMPLETELY SORTED,
! THE PROCESS BEGINS AGAIN BY RETRIEVING THE INDICES BOUNDING ANOTHER
! UNSORTED PORTION.

! INPUT PARAMETERS -   N - LENGTH OF THE ARRAY X.

!                      X - VECTOR OF LENGTH N TO BE SORTED.

!                    IND - VECTOR OF LENGTH >= N.

! N AND X ARE NOT ALTERED BY THIS ROUTINE.

! OUTPUT PARAMETER - IND - SEQUENCE OF INDICES 1,...,N PERMUTED IN THE SAME
!                          FASHION AS X WOULD BE.  THUS, THE ORDERING ON
!                          X IS DEFINED BY Y(I) = X(IND(I)).

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

! NOTE -- IU AND IL MUST BE DIMENSIONED >= LOG(N) WHERE LOG HAS BASE 2.
! (OK for N up to about a billon)

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

INTEGER   :: iu(21), il(21)
INTEGER   :: m, i, j, k, l, ij, it, itt, indx
REAL(r_single)      :: r
REAL(r_single)      :: t

! LOCAL PARAMETERS -

! IU,IL =  TEMPORARY STORAGE FOR THE UPPER AND LOWER
!            INDICES OF PORTIONS OF THE ARRAY X
! M =      INDEX FOR IU AND IL
! I,J =    LOWER AND UPPER INDICES OF A PORTION OF X
! K,L =    INDICES IN THE RANGE I,...,J
! IJ =     RANDOMLY CHOSEN INDEX BETWEEN I AND J
! IT,ITT = TEMPORARY STORAGE FOR INTERCHANGES IN IND
! INDX =   TEMPORARY INDEX FOR X
! R =      PSEUDO RANDOM NUMBER FOR GENERATING IJ
! T =      CENTRAL ELEMENT OF X

IF (n <= 0) RETURN

! INITIALIZE IND, M, I, J, AND R

DO  i = 1, n
  ind(i) = i
END DO
m = 1
i = 1
j = n
r = .375_r_single

! TOP OF LOOP

20 IF (i >= j) GO TO 70
IF (r <= .5898437_r_single) THEN
  r = r + .0390625_r_single
ELSE
  r = r - .21875_r_single
END IF

! INITIALIZE K

30 k = i

! SELECT A CENTRAL ELEMENT OF X AND SAVE IT IN T

ij = i + r*(j-i)
it = ind(ij)
t = x(it)

! IF THE FIRST ELEMENT OF THE ARRAY IS GREATER THAN T,
!   INTERCHANGE IT WITH T

indx = ind(i)
IF (x(indx) > t) THEN
  ind(ij) = indx
  ind(i) = it
  it = indx
  t = x(it)
END IF

! INITIALIZE L

l = j

! IF THE LAST ELEMENT OF THE ARRAY IS LESS THAN T,
!   INTERCHANGE IT WITH T

indx = ind(j)
IF (x(indx) >= t) GO TO 50
ind(ij) = indx
ind(j) = it
it = indx
t = x(it)

! IF THE FIRST ELEMENT OF THE ARRAY IS GREATER THAN T,
!   INTERCHANGE IT WITH T

indx = ind(i)
IF (x(indx) <= t) GO TO 50
ind(ij) = indx
ind(i) = it
it = indx
t = x(it)
GO TO 50

! INTERCHANGE ELEMENTS K AND L

40 itt = ind(l)
ind(l) = ind(k)
ind(k) = itt

! FIND AN ELEMENT IN THE UPPER PART OF THE ARRAY WHICH IS
!   NOT LARGER THAN T

50 l = l - 1
indx = ind(l)
IF (x(indx) > t) GO TO 50

! FIND AN ELEMENT IN THE LOWER PART OF THE ARRAY WHCIH IS NOT SMALLER THAN T

60 k = k + 1
indx = ind(k)
IF (x(indx) < t) GO TO 60

! IF K <= L, INTERCHANGE ELEMENTS K AND L

IF (k <= l) GO TO 40

! SAVE THE UPPER AND LOWER SUBSCRIPTS OF THE PORTION OF THE
!   ARRAY YET TO BE SORTED

IF (l-i > j-k) THEN
  il(m) = i
  iu(m) = l
  i = k
  m = m + 1
  GO TO 80
END IF

il(m) = k
iu(m) = j
j = l
m = m + 1
GO TO 80

! BEGIN AGAIN ON ANOTHER UNSORTED PORTION OF THE ARRAY

70 m = m - 1
IF (m == 0) RETURN
i = il(m)
j = iu(m)

80 IF (j-i >= 11) GO TO 30
IF (i == 1) GO TO 20
i = i - 1

! SORT ELEMENTS I+1,...,J.  NOTE THAT 1 <= I < J AND J-I < 11.

90 i = i + 1
IF (i == j) GO TO 70
indx = ind(i+1)
t = x(indx)
it = indx
indx = ind(i)
IF (x(indx) <= t) GO TO 90
k = i

100 ind(k+1) = ind(k)
k = k - 1
indx = ind(k)
IF (t < x(indx)) GO TO 100

ind(k+1) = it
GO TO 90
END SUBROUTINE quicksort
! --------------------------------------------------------------------
! INTEGER FUNCTION  FindMinimum():
!    This function returns the location of the minimum in the section
! between Start and End.
! --------------------------------------------------------------------

   INTEGER FUNCTION  FindMinimum(x, Start, End)
      IMPLICIT  NONE
      INTEGER(i_kind), DIMENSION(1:), INTENT(IN) :: x
      INTEGER, INTENT(IN)                :: Start, End
      INTEGER                            :: Minimum
      INTEGER                            :: Location
      INTEGER                            :: i

      Minimum  = x(Start)		! assume the first is the min
      Location = Start			! record its position
      DO i = Start+1, End		! start with next elements
         IF (x(i) < Minimum) THEN	!   if x(i) less than the min?
            Minimum  = x(i)		!      Yes, a new minimum found
            Location = i                !      record its position
         END IF
      END DO
      FindMinimum = Location        	! return the position
   END FUNCTION  FindMinimum

! --------------------------------------------------------------------
! SUBROUTINE  Swap():
!    This subroutine swaps the values of its two formal arguments.
! --------------------------------------------------------------------

   SUBROUTINE  Swap(a, b)
      IMPLICIT  NONE
      INTEGER(i_kind), INTENT(INOUT) :: a, b
      INTEGER(i_kind)        :: Temp

      Temp = a
      a    = b
      b    = Temp
   END SUBROUTINE  Swap

! --------------------------------------------------------------------
! SUBROUTINE  Sort():
!    This subroutine receives an array x() and sorts it into ascending
! order.
! --------------------------------------------------------------------

   SUBROUTINE  ISort(x, Size)
      IMPLICIT  NONE
      INTEGER(i_kind), DIMENSION(1:), INTENT(INOUT) :: x
      INTEGER, INTENT(IN)                   :: Size
      INTEGER                               :: i
      INTEGER                               :: Location

      DO i = 1, Size-1			! except for the last
         Location = FindMinimum(x, i, Size)	! find min from this to last
         CALL  Swap(x(i), x(Location))	! swap this and the minimum
      END DO
   END SUBROUTINE  ISort
end module sorting


! { dg-do compile }
! { dg-options "-O2 -ffast-math -fdump-tree-pre" }

      subroutine foo(U,V,R,N,A)
      integer N
      real*8 U(N,N,N),V(N,N,N),R(N,N,N),A(0:3)
      integer I3, I2, I1
C
      do I3=2,N-1
       do I2=2,N-1
        do I1=2,N-1
         R(I1,I2,I3)=V(I1,I2,I3)
     *      -A(0)*( U(I1,  I2,  I3  ) )
     *      -A(1)*( U(I1-1,I2,  I3  ) + U(I1+1,I2,  I3  )
     *                 +  U(I1,  I2-1,I3  ) + U(I1,  I2+1,I3  )
     *                 +  U(I1,  I2,  I3-1) + U(I1,  I2,  I3+1) )
     *      -A(2)*( U(I1-1,I2-1,I3  ) + U(I1+1,I2-1,I3  )
     *                 +  U(I1-1,I2+1,I3  ) + U(I1+1,I2+1,I3  )
     *                 +  U(I1,  I2-1,I3-1) + U(I1,  I2+1,I3-1)
     *                 +  U(I1,  I2-1,I3+1) + U(I1,  I2+1,I3+1)
     *                 +  U(I1-1,I2,  I3-1) + U(I1-1,I2,  I3+1)
     *                 +  U(I1+1,I2,  I3-1) + U(I1+1,I2,  I3+1) )
     *      -A(3)*( U(I1-1,I2-1,I3-1) + U(I1+1,I2-1,I3-1)
     *                 +  U(I1-1,I2+1,I3-1) + U(I1+1,I2+1,I3-1)
     *                 +  U(I1-1,I2-1,I3+1) + U(I1+1,I2-1,I3+1)
     *                 +  U(I1-1,I2+1,I3+1) + U(I1+1,I2+1,I3+1) )
        enddo
       enddo
      enddo
      return
      end

! PRE shouldn't do predictive commonings job here (and in a bad way)
! ???  It still does but not as bad as it could.  Less prephitmps
! would be better, pcom does it with 6.
! { dg-final { scan-tree-dump-times "# prephitmp" 9 "pre" } }


      SUBROUTINE bessjy(x,xnu,rj,ry,rjp,ryp)
      INTEGER MAXIT
      REAL rj,rjp,ry,ryp,x,xnu,XMIN
      DOUBLE PRECISION EPS,FPMIN,PI
      PARAMETER (EPS=1.e-10,FPMIN=1.e-30,MAXIT=10000,XMIN=2.,
     *PI=3.141592653589793d0)
CU    USES beschb
      INTEGER i,isign,l,nl
      DOUBLE PRECISION a,b,br,bi,c,cr,ci,d,del,del1,den,di,dlr,dli,dr,e,
     *f,fact,fact2,fact3,ff,gam,gam1,gam2,gammi,gampl,h,p,pimu,pimu2,q,
     *r,rjl,rjl1,rjmu,rjp1,rjpl,rjtemp,ry1,rymu,rymup,rytemp,sum,sum1,
     *temp,w,x2,xi,xi2,xmu,xmu2
      if(x.le.0..or.xnu.lt.0.) pause 'bad arguments in bessjy'
      if(x.lt.XMIN)then
        nl=int(xnu+.5d0)
      else
        nl=max(0,int(xnu-x+1.5d0))
      endif
      xmu=xnu-nl
      xmu2=xmu*xmu
      xi=1.d0/x
      xi2=2.d0*xi
      w=xi2/PI
      isign=1
      h=xnu*xi
      if(h.lt.FPMIN)h=FPMIN
      b=xi2*xnu
      d=0.d0
      c=h
      do 11 i=1,MAXIT
        b=b+xi2
        d=b-d
        if(abs(d).lt.FPMIN)d=FPMIN
        c=b-1.d0/c
        if(abs(c).lt.FPMIN)c=FPMIN
        d=1.d0/d
        del=c*d
        h=del*h
        if(d.lt.0.d0)isign=-isign
        if(abs(del-1.d0).lt.EPS)goto 1
11    continue
      pause 'x too large in bessjy; try asymptotic expansion'
1     continue
      rjl=isign*FPMIN
      rjpl=h*rjl
      rjl1=rjl
      rjp1=rjpl
      fact=xnu*xi
      do 12 l=nl,1,-1
        rjtemp=fact*rjl+rjpl
        fact=fact-xi
        rjpl=fact*rjtemp-rjl
        rjl=rjtemp
12    continue
      if(rjl.eq.0.d0)rjl=EPS
      f=rjpl/rjl
      if(x.lt.XMIN) then
        x2=.5d0*x
        pimu=PI*xmu
        if(abs(pimu).lt.EPS)then
          fact=1.d0
        else
          fact=pimu/sin(pimu)
        endif
        d=-log(x2)
        e=xmu*d
        if(abs(e).lt.EPS)then
          fact2=1.d0
        else
          fact2=sinh(e)/e
        endif
        call beschb(xmu,gam1,gam2,gampl,gammi)
        ff=2.d0/PI*fact*(gam1*cosh(e)+gam2*fact2*d)
        e=exp(e)
        p=e/(gampl*PI)
        q=1.d0/(e*PI*gammi)
        pimu2=0.5d0*pimu
        if(abs(pimu2).lt.EPS)then
          fact3=1.d0
        else
          fact3=sin(pimu2)/pimu2
        endif
        r=PI*pimu2*fact3*fact3
        c=1.d0
        d=-x2*x2
        sum=ff+r*q
        sum1=p
        do 13 i=1,MAXIT
          ff=(i*ff+p+q)/(i*i-xmu2)
          c=c*d/i
          p=p/(i-xmu)
          q=q/(i+xmu)
          del=c*(ff+r*q)
          sum=sum+del
          del1=c*p-i*del
          sum1=sum1+del1
          if(abs(del).lt.(1.d0+abs(sum))*EPS)goto 2
13      continue
        pause 'bessy series failed to converge'
2       continue
        rymu=-sum
        ry1=-sum1*xi2
        rymup=xmu*xi*rymu-ry1
        rjmu=w/(rymup-f*rymu)
      else
        a=.25d0-xmu2
        p=-.5d0*xi
        q=1.d0
        br=2.d0*x
        bi=2.d0
        fact=a*xi/(p*p+q*q)
        cr=br+q*fact
        ci=bi+p*fact
        den=br*br+bi*bi
        dr=br/den
        di=-bi/den
        dlr=cr*dr-ci*di
        dli=cr*di+ci*dr
        temp=p*dlr-q*dli
        q=p*dli+q*dlr
        p=temp
        do 14 i=2,MAXIT
          a=a+2*(i-1)
          bi=bi+2.d0
          dr=a*dr+br
          di=a*di+bi
          if(abs(dr)+abs(di).lt.FPMIN)dr=FPMIN
          fact=a/(cr*cr+ci*ci)
          cr=br+cr*fact
          ci=bi-ci*fact
          if(abs(cr)+abs(ci).lt.FPMIN)cr=FPMIN
          den=dr*dr+di*di
          dr=dr/den
          di=-di/den
          dlr=cr*dr-ci*di
          dli=cr*di+ci*dr
          temp=p*dlr-q*dli
          q=p*dli+q*dlr
          p=temp
          if(abs(dlr-1.d0)+abs(dli).lt.EPS)goto 3
14      continue
        pause 'cf2 failed in bessjy'
3       continue
        gam=(p-f)/q
        rjmu=sqrt(w/((p-f)*gam+q))
        rjmu=sign(rjmu,rjl)
        rymu=rjmu*gam
        rymup=rymu*(p+q/gam)
        ry1=xmu*xi*rymu-rymup
      endif
      fact=rjmu/rjl
      rj=rjl1*fact
      rjp=rjp1*fact
      do 15 i=1,nl
        rytemp=(xmu+i)*xi2*ry1-rymu
        rymu=ry1
        ry1=rytemp
15    continue
      ry=rymu
      ryp=xnu*xi*rymu-ry1
      return
      END

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