      SUBROUTINE  CGAM(CARG,CANS,ERREST,MODE)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1996-03-30 CGAM  Krogh   Added external statement.
C>> 1995-11-20 CGAM Krogh Set up so M77CON converts between "Z" and "C".
C>> 1994-08-17 CLL Add tests on BIGINT to allow easier conversion to C.
C>> 1994-05-25 CGAM WVS generate COEF using PARAMETER
C>> 1994-04-20 CGAM CLL Make DP and SP versions similar.
C>> 1993-04-13 CGAM CLL Edit for conversion to C.
C>> 1992-04-20 CGAM CLL Edited comments.
C>> 1991-11-11 CGAM CLL Made [Z/C]GAM from CDLGAM
C>> 1991-01-16 CDLGAM Lawson  Removing use of subr D2MACH.
C>> 1985-08-02 CDLGAM Lawson  Initial code.
C
C *** COMPLEX GAMMA AND LOGGAMMA FUNCTIONS WITH ERROR ESTIMATE
C
C     -----------------------------------------------------------------
C     SUBROUTINE ARGUMENTS
C     --------------------
C     CARG()   A complex argument, given as an array of 2 floating-point
c              elements consisting of the real component
c              followed by the imaginary component.
c
c     CANS()   The complex answer, stored as an array of 2
c              floating-point numbers, representing the real and
c              imaginary parts.
c
c     ERREST   On output ERREST gives an estimate of the absolute
c              (for LOGGAMMA) or the relative (for GAMMA) error
c              of the answer.
c
c     MODE     Selects function to be computed.  set it to 0 for
c              LOGGAMMA, and 1 for GAMMA.
C     -----------------------------------------------------------------
C     MACHINE DEPENDANT PARAMETERS
C     If the fraction part of a floating point number
C     contains T digits using base B then
C         EPS3  = B ** (-T)
C         EPS4  = B ** (-T+1)
C         OMEGA = overflow limit
C         DESET = 5.0 on a binary machine
C               = 2.0 on a base 16 machine
C     -----------------------------------------------------------------
C     REFERENCE: H.KUKI, Comm.ACM, Vol.15, (1972),
C     pp.262-267, 271-272.  Subroutine name was CDLGAM.
C     Code developed for UNIVAC 1108 by E.W.NG, JPL, 1969.
C     Modified for FORTRAN 77 portability by C.L.LAWSON &
C     S.CHAN, JPL, 1983.
c     -----------------------------------------------------------------
c--C replaces "?": ?GAM
c--S (type)replaces "?": ?ERM1, ?ERV1
c     Also uses I1MACH, and R1MACH
c     -----------------------------------------------------------------
      external         I1MACH, R1MACH
      real             R1MACH
      real             A,AL1,AL2,AL2P,B,BIGINT
      real             CARG(2),CANS(2),COEF(7), CUT1
      real             DE0,DE1,DELTA,DESET,DN
      real             ELIMIT, EPS3, EPS4,ERREST,F0,F1,G0,G1
      real             H,H1,H2,HL2P,OMEGA, ONE
      real             PI, REPS3, T1,T2,TWOPI
      real             U,U1,U2,UU1,UU2,UUU1,UUU2,V1,V2,VV1,VV2
      real             W1,W2,W3,Y1,Z1,Z2, ZERO, ZZ1
      integer I1MACH, ITEMP, J, K, LF1, LF2, LF3, MODE, N
      logical FIRST
C
      SAVE FIRST,BIGINT,COEF,OMEGA,EPS4,EPS3,REPS3,CUT1,DESET,ELIMIT
C
      parameter(ONE = 1.0E0, ZERO = 0.0E0)
      parameter(F0 = 840.07385296052619E0, F1 = 20.001230821894200E0)
      parameter(G0 = 1680.1477059210524E0, G1 = 180.01477047052042E0)
      parameter(PI = 3.14159265358979323846E0)
      parameter(TWOPI = 6.283185307179586476925E0)
      parameter(HL2P = 0.918938533204672742E0)
      parameter(AL2P = 1.83787706640934548E0)

c              COEF(8-i) = bernoulli(2i)/(2i*(2i-1)).
      real             C1, C2, C3, C4, C5, C6, C7
      parameter (C1 = +1.0e0/156.0e0)
      parameter (C2 = -691.0e0/360360.0e0)
      parameter (C3 = +1.0e0/1188.0e0)
      parameter (C4 = -1.0e0/1680.0e0)
      parameter (C5 = +1.0e0/1260.0e0)
      parameter (C6 = -1.0e0/360.0e0)
      parameter (C7 = +1.0e0/12.0e0)
      DATA COEF / C1, C2, C3, C4, C5, C6, C7 /
c     DATA COEF   /+0.641025641025641026E-2,
c    *             -0.191752691752691753E-2,
c    *             +0.841750841750841751E-3,
c    *             -0.595238095238095238E-3,
c    *             +0.793650793650793651E-3,
c    *             -0.277777777777777778E-2,
c    *             +0.833333333333333333E-1/
      DATA FIRST/.TRUE./
c     ------------------------------------------------------------------
      IF (FIRST) THEN
        FIRST = .FALSE.
        OMEGA = R1MACH(2)
        EPS3  = R1MACH(3)
        EPS4  = R1MACH(4)
        REPS3 = ONE / EPS3
        ELIMIT = log(OMEGA)
        CUT1  = log(EPS3)
        BIGINT = I1MACH(9) - 2
          IF (I1MACH(10) .EQ. 2) THEN
            DESET = 5.E0
          ELSE
            DESET = 2.E0
          ENDIF
      ENDIF
      DE0 = DESET
      DE1 = ZERO
      Z1 = CARG(1)
      Z2 = CARG(2)
C
C *** Setting DELTA = estimate of uncertainty level of
C                     argument data.
C
      DELTA = EPS4 * (abs(Z1) + abs(Z2))
      IF (DELTA .EQ. ZERO) DELTA = EPS4
C
C *** FORCE SIGN OF IMAGINARY PART OF ARG TO NON-NEGATIVE
C
      LF1 = 0
      IF (Z2 .lt. ZERO) then
         LF1 = 1
         Z2 = -Z2
      endif
      LF2 = 0
      IF (Z1 .GE. ZERO) GO TO 100
C
C *** CASE WHEN REAL PART OF ARG IS NEGATIVE
C
      LF2 = 1
      LF1 = LF1-1
      T1 = AL2P - PI*Z2
      T2 = PI*(0.5E0 - Z1)
      U  = -TWOPI*Z2
      IF (U .lt. -0.1054E0) then
         A  = ZERO
C
C ***    IF EXP(U) .LE. EPS3, IGNORE IT TO SAVE TIME AND TO AVOID
C        IRRELEVANT UNDERFLOW
C
         IF (U .gt. CUT1) then
            A  = exp(U)
         endif
         H1 = ONE - A
      else
         U2 = U * U
         A  = -U*(F1*U2 + F0)
         H1 = (A + A)/((U2 + G1)*U2 + G0 + A)
         A  = ONE - H1
      endif
c
c              Here Z1 is negative.
c
      if(Z1 .lt. -BIGINT) then
         CALL SERM1('CGAM',3,0,'Require CARG(1) .ge. -BIGINT',
     *              'CARG(1)', Z1, ',')
         CALL SERV1('-BIGINT',-BIGINT,'.')
         go to 700
      endif
c
c           Truncate to integer: ITEMP
c
      ITEMP = Z1 - 0.5e0
      B  = Z1 - ITEMP
      H2 = A*sin(TWOPI*B)
      B  = sin(PI*B)
      H1 = H1 + (B+B)*B*A
      H  = abs(H2) + H1 - TWOPI*A*DELTA
      IF (H .LE. ZERO) GO TO 500
      DE0 = DE0 + abs(T1) + T2
      DE1 = PI + TWOPI*A/H
      Z1 = ONE - Z1
C
C *** CASE WHEN NEITHER REAL PART NOR IMAGINARY PART OF ARG IS
C     NEGATIVE.  DEFINE THRESHOLD CURVE TO BE THE BROKEN LINES
C     CONNECTING POINTS 10F0*I, 10F4.142*I, 0.1F14.042*I,AND
C     0.1FOMEGA*I
C
  100 LF3 = 0
      Y1 = Z1 - 0.5E0
      W1 = ZERO
      W2 = ZERO
      K  = 0
      B  = max(0.1E0, min(10.0E0, 14.142E0-Z2)) - Z1
      IF (B .LE. ZERO) GO TO 200
C
C *** CASE WHEN REAL PART OF ARG IS BETWEEN 0 AND THRESHOLD
C
      LF3 = 1
      ZZ1 = Z1
      N  = B + ONE
      DN = N
      Z1 = Z1 + DN
      A  = Z1*Z1 + Z2*Z2
      V1 = Z1/A
      V2 = -Z2/A
C
C *** INITIALIZE U1+U2*I AS THE RIGHTMOST FACTOR 1-1/(Z+N)
C
      U1 = ONE - V1
      U2 = -V2
      K  = 6.0E0 - Z2*0.6E0 - ZZ1
      IF (K .gt. 0) then
C
C *** FORWARD ASSEMBLY OF FACTORS (Z+J-1)/(Z+N)
C
         N  = N - K
         UU1 = (ZZ1*Z1 + Z2*Z2) / A
         UU2 = DN*Z2/A
         VV1 = ZERO
         VV2 = ZERO
         DO 110  J = 1,K
            B  = U1*(UU1+VV1) - U2*(UU2+VV2)
            U2 = U1*(UU2+VV2) + U2*(UU1+VV1)
            U1 = B
            VV1 = VV1 + V1
            VV2 = VV2 + V2
  110    continue
      endif
      IF (N .GE. 2) then
C
C *** BACKWARD ASSEMBLY OF FACTORS 1-J/(Z+N)
C
         VV1 = V1
         VV2 = V2
         DO 130  J = 2,N
            VV1 = VV1 + V1
            VV2 = VV2 + V2
            B  = U1*(ONE - VV1) + U2*VV2
            U2 = -U1*VV2 + U2*(ONE - VV1)
            U1 = B
  130   continue
      endif
      U  = U1*U1 + U2*U2
      IF (U .EQ. ZERO) GO TO 500
      IF (MODE .NE. 0) then
         IF (K .LE. 0) GO TO 200
      endif
      AL1 = log(U)*0.5E0
      IF (MODE .EQ. 0) then
         W1 = AL1
         W2 = atan2(U2,U1)
         IF (W2 .LT. ZERO)  W2 = W2 + TWOPI
         IF (K .LE. 0) GO TO 200
      endif
      A  = ZZ1 + Z2 - DELTA
      IF (A .LE. ZERO) GO TO 500
      DE0 = DE0 - AL1
      DE1 = DE1 + 2.0E0 + ONE/A
C
C *** CASE WHEN REAL PART OF ARG IS GREATER THAN THRESHOLD
C
  200 A  = Z1*Z1 + Z2*Z2
      AL1 = log(A)*0.5E0
      AL2 = atan2(Z2,Z1)
      V1 = Y1*AL1 - Z2*AL2
      V2 = Y1*AL2 + Z2*AL1
C
C *** Evaluate asymptotic terms. Ignore this term,
C     if ABS(ARG)**2 .GT. REPS3, to save time and
C     to avoid irrelevant underflow.
C
      VV1 = ZERO
      VV2 = ZERO
      IF (A .GT. REPS3) GO TO 220
      UU1 = Z1/A
      UU2 = -Z2/A
      UUU1 = UU1*UU1 - UU2*UU2
      UUU2 = UU1*UU2*2.0E0
      VV1 = COEF(1)
      DO 210  J = 2,7
        B  = VV1*UUU1 - VV2*UUU2
        VV2 = VV1*UUU2 + VV2*UUU1
  210   VV1 = B + COEF(J)
      B  = VV1*UU1 - VV2*UU2
      VV2 = VV1*UU2 + VV2*UU1
      VV1 = B
  220 W1 = (((VV1 + HL2P) - W1) - Z1) + V1
      W2 = ((VV2 - W2) - Z2) + V2
      DE0 = DE0 + abs(V1) + abs(V2)
      IF (K .LE. 0)  DE1 = DE1 + AL1
C FINAL ASSEMBLY
      IF (LF2 .EQ. 0) then
         IF (MODE .NE. 0) then
            IF (W1 .GT. ELIMIT) GO TO 550
            A  = exp(W1)
            W1 = A*cos(W2)
            W2 = A*sin(W2)
            IF (LF3 .NE. 0) then
               B  = (W1*U1 + W2*U2) / U
               W2 = (W2*U1 - W1*U2) / U
               W1 = B
            endif
         endif
         GO TO 400
      endif
      H  = H1*H1 + H2*H2
      IF (H .EQ. ZERO) GO TO 500
      IF (MODE .EQ. 0 .or. H .le. 1.0E-2) then
         A  = log(H)*0.5E0
         IF (H .LE. 1.0E-2)  DE0 = DE0 - A
         IF (MODE .EQ. 0) then
            W1 = (T1 - A) - W1
            W2 = (T2 - atan2(H2,H1)) - W2
            GO TO 400
         endif
      endif
c                       Here we have MODE .ne. 0 and LF2 .ne. 0.
      T1 = T1 - W1
      T2 = T2 - W2
      IF (T1 .GT. ELIMIT) GO TO 550
      A  = exp(T1)
      T1 = A*cos(T2)
      T2 = A*sin(T2)
      W1 = (T1*H1 + T2*H2)/H
      W2 = (T2*H1 - T1*H2)/H
      IF (LF3 .NE. 0) then
         B  = W1*U1 - W2*U2
         W2 = W1*U2 + W2*U1
         W1 = B
      endif
  400 continue
      IF (LF1 .NE. 0)  W2 = -W2
C
C *** TRUNCATION ERREST OF STIRLINGS FORMULA IS UP TO EPS3.
C
      DE1 = DE0*EPS4 + EPS3 + DE1*DELTA

c                                      Normal termination.
c
c     The imaginary part of the log of a complex number is nonunique
c     to within multiples of 2*Pi.  We prefer a result for loggamma
c     having its imaginary part .gt. -Pi and .le. +Pi.  The result at
c     this point is usually in this range.  If not we will move it
c     into this range.  -- CLL 11/11/91
c
      if(MODE .eq. 0) then
         if(W2 .le. -PI .or. W2 .gt. PI) then
            W3 = abs(W2)
            T1 = W3/PI + ONE
            if(abs(T1) .gt. BIGINT) then
               CALL SERM1('CGAM',4,0,'Argument out of range.',
     *                    'CARG(1)',CARG(1),',')
               CALL SERV1('CARG(2)',CARG(2),'.')
               go to 700
            endif
            T2 = int(T1) / 2
            W3 = W3 - T2 * TWOPI
            if(W2 .ge. 0.0e0) then
               W2 = W3
            else
               W2 = -W3
            endif
            if(W2 .le. -PI) then
               W2 = W2 + TWOPI
            elseif(W2 .gt. PI) then
               W2 = W2 - TWOPI
            endif
         endif
      endif
      CANS(1) = W1
      CANS(2) = W2
      ERREST = DE1
      return
c                                           Error termination.
C
C *** CASE WHEN ARGUMENT IS TOO CLOSE TO A SINGULARITY
C
  500 CONTINUE
      CALL SERM1('CGAM',1,0,'Z TOO CLOSE TO A SINGULARITY',
     *           'Z(1)',CARG(1),',')
      CALL SERV1('Z(2)',CARG(2),'.')
      GO TO 700
C
  550 CONTINUE
      CALL SERM1('CGAM',2,0,'ARG TOO LARGE. EXP FUNCTION OVERFLOW',
     *           'Z(1)',CARG(1),',')
      CALL SERV1('Z(2)',CARG(2),'.')
  700 continue
      CANS(1) = OMEGA
      CANS(2) = OMEGA
      ERREST = OMEGA
      return
      end


      SUBROUTINE LSQHARM
C
C CHANGE RECORD
C **  SUBROUTINE LSQHARM PERFORMS A LEAST SQUARES HARMONIC ANALYSIS
C
      USE GLOBAL

      CHARACTER*80 TITLE,TITNT,TITRT
      REAL,SAVE,ALLOCATABLE,DIMENSION(:)::AMATMP
      REAL,SAVE,ALLOCATABLE,DIMENSION(:)::PPPTMP
      REAL,SAVE,ALLOCATABLE,DIMENSION(:)::P0

      IF(.NOT.ALLOCATED(AMATMP))THEN
		ALLOCATE(AMATMP(MTM))
		ALLOCATE(PPPTMP(MTM))
		ALLOCATE(P0(MLM))
	    AMATMP=0.0
	    PPPTMP=0.0
	    P0=0.0
	ENDIF
C
      TITRT='TREND, P0+P1DT1*T, REMOVED'
      TITNT='TREND NOT REMOVED'
      IF(JSLSHA.EQ.0) GOTO 100
      JSLSHA=0
C
C **  INITIALIZE COEFFICIENT ARRAYS AND CONSTANTS
C
      RMLSHA=0.
      RTLSHA=0.
      RTTLSHA=0.
      DO MC=1,MTIDE
        CLSHA(MC)=0.
        SLSHA(MC)=0.
        CTLSHA(MC)=0.
        STLSHA(MC)=0.
        DO MR=1,MTIDE
          CCLSHA(MR,MC)=0.
          SSLSHA(MR,MC)=0.
          CSLSHA(MR,MC)=0.
          SCLSHA(MR,MC)=0.
        ENDDO
      ENDDO
C
C **  INITIALIZE RHS ARRAYS
C
      DO ML=1,MLLSHA
        I=ILLSHA(ML)
        J=JLLSHA(ML)
        LLSHA(ML)=LIJ(I,J)
      ENDDO
      DO ML=1,MLLSHA
        PLSHA(ML)=0.
        PTLSHA(ML)=0.
        UELSHA(ML)=0.
        UETLSHA(ML)=0.
        VELSHA(ML)=0.
        VETLSHA(ML)=0.
        DO K=1,KC
          BLSHA(K,ML)=0.
          BTLSHA(K,ML)=0.
          ULSHA(K,ML)=0.
          UTLSHA(K,ML)=0.
          VLSHA(K,ML)=0.
          VTLSHA(K,ML)=0.
        ENDDO
      ENDDO
      DO MC=1,MTIDE
        DO ML=1,MLLSHA
          PCLSHA(ML,MC)=0.
          PSLSHA(ML,MC)=0.
          UECLSHA(ML,MC)=0.
          UESLSHA(ML,MC)=0.
          VECLSHA(ML,MC)=0.
          VESLSHA(ML,MC)=0.
          DO K=1,KC
            BCLSHA(K,ML,MC)=0.
            BSLSHA(K,ML,MC)=0.
            UCLSHA(K,ML,MC)=0.
            USLSHA(K,ML,MC)=0.
            VCLSHA(K,ML,MC)=0.
            VSLSHA(K,ML,MC)=0.
          ENDDO
        ENDDO
      ENDDO
  100 CONTINUE
      IF(LSLSHA.EQ.1) GOTO 200
C
C **  ACCUMULATE ARRAYS
C
      IF(ISDYNSTP.EQ.0)THEN
        TIME=DT*FLOAT(N)+TCON*TBEGIN
      ELSE
        TIME=TIMESEC
      ENDIF
      DO M=1,MTIDE
        TMOD=MOD(TIME,TCP(M))
        TMOD=PI2*TMOD/TCP(M)
        CCCC(M)=COS(TMOD)
        SSSS(M)=SIN(TMOD)
      ENDDO
C
C **  ACCUMULATE COEFFICIENT ARRAYS
C
      RMLSHA=RMLSHA+1.
      RTLSHA=RTLSHA+TIME
      RTTLSHA=RTTLSHA+TIME*TIME
      DO MC=1,MTIDE
        CLSHA(MC)=CLSHA(MC)+CCCC(MC)
        SLSHA(MC)=SLSHA(MC)+SSSS(MC)
        CTLSHA(MC)=CTLSHA(MC)+TIME*CCCC(MC)
        STLSHA(MC)=STLSHA(MC)+TIME*SSSS(MC)
        DO MR=1,MTIDE
          CCLSHA(MR,MC)=CCLSHA(MR,MC)+CCCC(MR)*CCCC(MC)
          SSLSHA(MR,MC)=SSLSHA(MR,MC)+SSSS(MR)*SSSS(MC)
          CSLSHA(MR,MC)=CSLSHA(MR,MC)+CCCC(MR)*SSSS(MC)
          SCLSHA(MR,MC)=SCLSHA(MR,MC)+SSSS(MR)*CCCC(MC)
        ENDDO
      ENDDO
C
C **  ACCUMULATE RHS ARRAYS
C
      DO ML=1,MLLSHA
        L=LLSHA(ML)
        LN=LNC(L)
        PLSHA(ML)=PLSHA(ML)+GI*P(L)
        PTLSHA(ML)=PTLSHA(ML)+GI*TIME*P(L)
        UTMP1=0.5*(UHDYE(LEAST(L))+UHDYE(L))/(DYP(L)*HP(L))
        VTMP1=0.5*(VHDXE(LN)+VHDXE(L))/(DXP(L)*HP(L))
        UTMP=CUE(L)*UTMP1+CVE(L)*VTMP1
        VTMP=CUN(L)*UTMP1+CVN(L)*VTMP1
        UELSHA(ML)=UELSHA(ML)+UTMP
        UETLSHA(ML)=UETLSHA(ML)+TIME*UTMP
        VELSHA(ML)=VELSHA(ML)+VTMP
        VETLSHA(ML)=VETLSHA(ML)+TIME*VTMP
        DO K=1,KC
          UTMP1=0.5*(U(LEAST(L),K)+U(L,K))
          VTMP1=0.5*(V(LN,K)+V(L,K))
          UTMP=CUE(L)*UTMP1+CVE(L)*VTMP1
          VTMP=CUN(L)*UTMP1+CVN(L)*VTMP1
          BLSHA(K,ML)=BLSHA(K,ML)+B(L,K)
          BTLSHA(K,ML)=BTLSHA(K,ML)+TIME*B(L,K)
          ULSHA(K,ML)=ULSHA(K,ML)+UTMP
          UTLSHA(K,ML)=UTLSHA(K,ML)+TIME*UTMP
          VLSHA(K,ML)=VLSHA(K,ML)+VTMP
          VTLSHA(K,ML)=VTLSHA(K,ML)+TIME*VTMP
        ENDDO
      ENDDO
      DO ML=1,MLLSHA
        L=LLSHA(ML)
        LN=LNC(L)
        DO MC=1,MTIDE
          PCLSHA(ML,MC)=PCLSHA(ML,MC)+GI*P(L)*CCCC(MC)
          PSLSHA(ML,MC)=PSLSHA(ML,MC)+GI*P(L)*SSSS(MC)
          UTMP1=0.5*(UHDYE(LEAST(L))+UHDYE(L))/(DYP(L)*HP(L))
          VTMP1=0.5*(VHDXE(LN)+VHDXE(L))/(DXP(L)*HP(L))
          UTMP=CUE(L)*UTMP1+CVE(L)*VTMP1
          VTMP=CUN(L)*UTMP1+CVN(L)*VTMP1
          UECLSHA(ML,MC)=UECLSHA(ML,MC)+CCCC(MC)*UTMP
          UESLSHA(ML,MC)=UESLSHA(ML,MC)+SSSS(MC)*UTMP
          VECLSHA(ML,MC)=VECLSHA(ML,MC)+CCCC(MC)*VTMP
          VESLSHA(ML,MC)=VESLSHA(ML,MC)+SSSS(MC)*VTMP
          DO K=1,KC
            UTMP1=0.5*(U(LEAST(L),K)+U(L,K))
            VTMP1=0.5*(V(LN,K)+V(L,K))
            UTMP=CUE(L)*UTMP1+CVE(L)*VTMP1
            VTMP=CUN(L)*UTMP1+CVN(L)*VTMP1
            BCLSHA(K,ML,MC)=BCLSHA(K,ML,MC)+B(L,K)*CCCC(MC)
            BSLSHA(K,ML,MC)=BSLSHA(K,ML,MC)+B(L,K)*SSSS(MC)
            UCLSHA(K,ML,MC)=UCLSHA(K,ML,MC)+CCCC(MC)*UTMP
            USLSHA(K,ML,MC)=USLSHA(K,ML,MC)+SSSS(MC)*UTMP
            VCLSHA(K,ML,MC)=VCLSHA(K,ML,MC)+CCCC(MC)*VTMP
            VSLSHA(K,ML,MC)=VSLSHA(K,ML,MC)+SSSS(MC)*VTMP
          ENDDO
        ENDDO
      ENDDO
      RETURN
C
C *** COMPLETE ANALYSIS
C
  200 CONTINUE
      OPEN(97,FILE='LSHA.OUT',STATUS='UNKNOWN')
      CLOSE(97,STATUS='DELETE')
      OPEN(97,FILE='LSHA.OUT',STATUS='UNKNOWN')
      IF(ISLSTR.EQ.1) GOTO 500
C
C *** COMPUTE SOLUTION WITH NO TREND REMOVAL
C *** LOAD GLOBAL COEFFICIENT MATRIX
C
      MG=2*MTIDE+1
      GLSHA(1,1)=RMLSHA
      DO MC=1,MTIDE
        MCP1=MC+1
        MCPP=MC+1+MTIDE
        GLSHA(1,MCP1)=CLSHA(MC)
        GLSHA(1,MCPP)=SLSHA(MC)
        GLSHA(MCP1,1)=CLSHA(MC)
        GLSHA(MCPP,1)=SLSHA(MC)
        DO MR=1,MTIDE
          MRP1=MR+1
          MRPP=MR+1+MTIDE
          GLSHA(MRP1,MCP1)=CCLSHA(MR,MC)
          GLSHA(MRPP,MCPP)=SSLSHA(MR,MC)
          GLSHA(MRP1,MCPP)=CSLSHA(MR,MC)
          GLSHA(MRPP,MCP1)=SCLSHA(MR,MC)
        ENDDO
      ENDDO
C
C *** PERFORM SVD ON GLSHA
C
      CALL SVDCMP (GLSHA,MG,MG,MGM,MGM,WLSHA,VVLSHA)
      WRITE(97,10)TITNT
      WRITE(97,11)
      DO M=1,MG
        WRITE(97,12)WLSHA(M)
      ENDDO
      WRITE(97,13)
C
C *** SOLVE BY BACK SUBSTITUTION AND OUTPUT RESULTS
C
      TITLE='FREE SURFACE DISPLACEMENT, NO TREND REMOVED'
      DO ML=1,MLLSHA
        IF(LSHAP(ML).EQ.1)THEN
          WRITE(97,10)TITLE
          WRITE(97,14)CLSL(ML),ILLSHA(ML),JLLSHA(ML)
          RHS(1)=PLSHA(ML)
          DO MC=1,MTIDE
            MCP1=MC+1
            MCPP=MC+1+MTIDE
            RHS(MCP1)=PCLSHA(ML,MC)
            RHS(MCPP)=PSLSHA(ML,MC)
          ENDDO
          CALL SVBKSB (GLSHA,WLSHA,VVLSHA,MG,MG,MGM,MGM,RHS,RSOL)
          WRITE(97,16)RSOL(1)
          WRITE(97,22)
          DO MC=1,MTIDE
            MCP1=MC+1
            MCPP=MC+1+MTIDE
            AMP=SQRT(RSOL(MCP1)*RSOL(MCP1)
     &          +RSOL(MCPP)*RSOL(MCPP))
            IF(RSOL(MCPP).EQ.0.0.AND.RSOL(MCP1).EQ.0.0)THEN
              PHI=999999.
            ELSE
              PHI=ATAN2(RSOL(MCPP),RSOL(MCP1))
            ENDIF
            PHASE=TCP(MC)*PHI/PI2
            IF(PHASE.LT.0.) PHASE=PHASE+TCP(MC)
            AMATMP(MC)=AMP
            PPPTMP(MC)=PHASE/3600.
            WRITE(97,230)AMP,PHASE,RSOL(MCP1),RSOL(MCPP),SYMBOL(MC)
          ENDDO
          WRITE(97,41)
          DO MC=1,MTIDE
            WRITE(97,40)AMATMP(MC)
          ENDDO
          WRITE(97,41)
          DO MC=1,MTIDE
            PPPTMP(MC)=3600.*PPPTMP(MC)
            WRITE(97,42)PPPTMP(MC)
          ENDDO
          WRITE(97,13)
        ENDIF
      ENDDO
      TITLE='SALINITY, NO TREND REMOVED'
      DO ML=1,MLLSHA
        IF(LSHAB(ML).EQ.1)THEN
          DO K=1,KC
            WRITE(97,10)TITLE
            WRITE(97,15)CLSL(ML),ILLSHA(ML),JLLSHA(ML),K
            RHS(1)=BLSHA(K,ML)
            DO MC=1,MTIDE
              MCP1=MC+1
              MCPP=MC+1+MTIDE
              RHS(MCP1)=BCLSHA(K,ML,MC)
              RHS(MCPP)=BSLSHA(K,ML,MC)
            ENDDO
            CALL SVBKSB (GLSHA,WLSHA,VVLSHA,MG,MG,MGM,MGM,RHS,RSOL)
            WRITE(97,16)RSOL(1)
            WRITE(97,22)
            DO MC=1,MTIDE
              MCP1=MC+1
              MCPP=MC+1+MTIDE
              AMP=SQRT(RSOL(MCP1)*RSOL(MCP1)
     &            +RSOL(MCPP)*RSOL(MCPP))
              IF(RSOL(MCPP).EQ.0.0.AND.RSOL(MCP1).EQ.0.0)THEN
                PHI=999999.
              ELSE
                PHI=ATAN2(RSOL(MCPP),RSOL(MCP1))
              ENDIF
              PHASE=TCP(MC)*PHI/PI2
              IF(PHASE.LT.0.) PHASE=PHASE+TCP(MC)
              AMATMP(MC)=AMP
              PPPTMP(MC)=PHASE/3600.
              WRITE(97,23)SYMBOL(MC),TCP(MC),AMP,PHASE
            ENDDO
            WRITE(97,41)
            DO MC=1,MTIDE
              WRITE(97,40)AMATMP(MC)
            ENDDO
            WRITE(97,41)
            DO MC=1,MTIDE
              WRITE(97,40)PPPTMP(MC)
            ENDDO
            WRITE(97,13)
          ENDDO
        ENDIF
      ENDDO
      TITLE='HORIZONTAL EXTERNAL MODE VELOCITY, NO TREND REMOVED'
      DO ML=1,MLLSHA
        IF(LSHAUE(ML).EQ.1)THEN
          RHS(1)=UELSHA(ML)
          DO MC=1,MTIDE
            MCP1=MC+1
            MCPP=MC+1+MTIDE
            RHS(MCP1)=UECLSHA(ML,MC)
            RHS(MCPP)=UESLSHA(ML,MC)
          ENDDO
          CALL SVBKSB (GLSHA,WLSHA,VVLSHA,MG,MG,MGM,MGM,RHS,RSOL)
          UMEAN=RSOL(1)
          DO MC=1,MTIDE
            MCP1=MC+1
            MCPP=MC+1+MTIDE
            AMPU(MC)=SQRT(RSOL(MCP1)*RSOL(MCP1)
     &          +RSOL(MCPP)*RSOL(MCPP))
            UCOS(MC)=RSOL(MCP1)
            USIN(MC)=RSOL(MCPP)
            IF(RSOL(MCPP).EQ.0.0.AND.RSOL(MCP1).EQ.0.0)THEN
              PHI=999999.
            ELSE
              PHI=ATAN2(RSOL(MCPP),RSOL(MCP1))
            ENDIF
            PHASEU(MC)=TCP(MC)*PHI/PI2
            IF(PHASEU(MC).LT.0.) PHASEU(MC)=PHASEU(MC)+TCP(MC)
          ENDDO
          RHS(1)=VELSHA(ML)
          DO MC=1,MTIDE
            MCP1=MC+1
            MCPP=MC+1+MTIDE
            RHS(MCP1)=VECLSHA(ML,MC)
            RHS(MCPP)=VESLSHA(ML,MC)
          ENDDO
          CALL SVBKSB (GLSHA,WLSHA,VVLSHA,MG,MG,MGM,MGM,RHS,RSOL)
          VMEAN=RSOL(1)
          DO MC=1,MTIDE
            MCP1=MC+1
            MCPP=MC+1+MTIDE
            AMPV(MC)=SQRT(RSOL(MCP1)*RSOL(MCP1)
     &          +RSOL(MCPP)*RSOL(MCPP))
            VCOS(MC)=RSOL(MCP1)
            VSIN(MC)=RSOL(MCPP)
            IF(RSOL(MCPP).EQ.0.0.AND.RSOL(MCP1).EQ.0.0)THEN
              PHI=999999.
            ELSE
              PHI=ATAN2(RSOL(MCPP),RSOL(MCP1))
            ENDIF
            PHASEV(MC)=TCP(MC)*PHI/PI2
            IF(PHASEV(MC).LT.0.) PHASEV(MC)=PHASEV(MC)+TCP(MC)
          ENDDO
          DO MC=1,MTIDE
            TERM1=UCOS(MC)+VSIN(MC)
            TERM2=VCOS(MC)-USIN(MC)
            TERM3=UCOS(MC)-VSIN(MC)
            TERM4=VCOS(MC)+USIN(MC)
            RPLUS=0.5*SQRT(TERM1*TERM1+TERM2*TERM2)
            RMINS=0.5*SQRT(TERM3*TERM3+TERM4*TERM4)
            IF(TERM1.EQ.0.0.AND.TERM2.EQ.0.0)THEN
              APLUS=999999.
            ELSE
              APLUS=ATAN2(TERM2,TERM1)
            ENDIF
            IF(TERM3.EQ.0.0.AND.TERM4.EQ.0.0)THEN
              AMINS=999999.
            ELSE
              AMINS=ATAN2(TERM4,TERM3)
            ENDIF
            RMAJ(MC)=RPLUS+RMINS
            RMIN(MC)=RPLUS-RMINS
            ACCWX(MC)=(90./PI)*(APLUS+AMINS)
            PHASEE(MC)=(0.25/PI)*TCP(MC)*(AMINS-APLUS)
            IF(PHASEE(MC).LT.0.) PHASEE(MC)=PHASEE(MC)+TCP(MC)
          ENDDO
          WRITE(97,10)TITLE
          WRITE(97,14)CLSL(ML),ILLSHA(ML),JLLSHA(ML)
          WRITE(97,17)UMEAN,VMEAN
          WRITE(97,24)
          DO M=1,MTIDE
            WRITE(97,25)SYMBOL(M),TCP(M),AMPU(M),PHASEU(M),AMPV(M)
     &          ,PHASEV(M)
          ENDDO
          WRITE(97,13)
          WRITE(97,26)
          DO M=1,MTIDE
            WRITE(97,25)SYMBOL(M),TCP(M),RMAJ(M),RMIN(M),ACCWX(M)
     &          ,PHASEE(M)
          ENDDO
          WRITE(97,41)
          DO M=1,MTIDE
            WRITE(97,40)RMAJ(M)
          ENDDO
          WRITE(97,41)
          DO MC=1,MTIDE
            WRITE(97,40)RMIN(M)
          ENDDO
          WRITE(97,41)
          DO MC=1,MTIDE
            WRITE(97,40)ACCWX(M)
          ENDDO
          WRITE(97,41)
          DO MC=1,MTIDE
            WRITE(97,42)PPPTMP(MC)
          ENDDO
          WRITE(97,13)
        ENDIF
      ENDDO
      TITLE='HORIZONTAL VELOCITY, NO TREND REMOVED'
      DO ML=1,MLLSHA
        IF(LSHAU(ML).EQ.1)THEN
          DO K=1,KC
            RHS(1)=ULSHA(K,ML)
            DO MC=1,MTIDE
              MCP1=MC+1
              MCPP=MC+1+MTIDE
              RHS(MCP1)=UCLSHA(K,ML,MC)
              RHS(MCPP)=USLSHA(K,ML,MC)
            ENDDO
            CALL SVBKSB (GLSHA,WLSHA,VVLSHA,MG,MG,MGM,MGM,RHS,RSOL)
            UMEAN=RSOL(1)
            DO MC=1,MTIDE
              MCP1=MC+1
              MCPP=MC+1+MTIDE
              AMPU(MC)=SQRT(RSOL(MCP1)*RSOL(MCP1)
     &            +RSOL(MCPP)*RSOL(MCPP))
              UCOS(MC)=RSOL(MCP1)
              USIN(MC)=RSOL(MCPP)
              IF(RSOL(MCPP).EQ.0.0.AND.RSOL(MCP1).EQ.0.0)THEN
                PHI=999999.
              ELSE
                PHI=ATAN2(RSOL(MCPP),RSOL(MCP1))
              ENDIF
              PHASEU(MC)=TCP(MC)*PHI/PI2
              IF(PHASEU(MC).LT.0.) PHASEU(MC)=PHASEU(MC)+TCP(MC)
            ENDDO
            RHS(1)=VLSHA(K,ML)
            DO MC=1,MTIDE
              MCP1=MC+1
              MCPP=MC+1+MTIDE
              RHS(MCP1)=VCLSHA(K,ML,MC)
              RHS(MCPP)=VSLSHA(K,ML,MC)
            ENDDO
            CALL SVBKSB (GLSHA,WLSHA,VVLSHA,MG,MG,MGM,MGM,RHS,RSOL)
            VMEAN=RSOL(1)
            DO MC=1,MTIDE
              MCP1=MC+1
              MCPP=MC+1+MTIDE
              AMPV(MC)=SQRT(RSOL(MCP1)*RSOL(MCP1)
     &            +RSOL(MCPP)*RSOL(MCPP))
              VCOS(MC)=RSOL(MCP1)
              VSIN(MC)=RSOL(MCPP)
              IF(RSOL(MCPP).EQ.0.0.AND.RSOL(MCP1).EQ.0.0)THEN
                PHI=999999.
              ELSE
                PHI=ATAN2(RSOL(MCPP),RSOL(MCP1))
              ENDIF
              PHASEV(MC)=TCP(MC)*PHI/PI2
              IF(PHASEV(MC).LT.0.) PHASEV(MC)=PHASEV(MC)+TCP(MC)
            ENDDO
            DO MC=1,MTIDE
              TERM1=UCOS(MC)+VSIN(MC)
              TERM2=VCOS(MC)-USIN(MC)
              TERM3=UCOS(MC)-VSIN(MC)
              TERM4=VCOS(MC)+USIN(MC)
              RPLUS=0.5*SQRT(TERM1*TERM1+TERM2*TERM2)
              RMINS=0.5*SQRT(TERM3*TERM3+TERM4*TERM4)
              IF(TERM1.EQ.0.0.AND.TERM2.EQ.0.0)THEN
                APLUS=999999.
              ELSE
                APLUS=ATAN2(TERM2,TERM1)
              ENDIF
              IF(TERM3.EQ.0.0.AND.TERM4.EQ.0.0)THEN
                AMINS=999999.
              ELSE
                AMINS=ATAN2(TERM4,TERM3)
              ENDIF
              RMAJ(MC)=RPLUS+RMINS
              RMIN(MC)=RPLUS-RMINS
              ACCWX(MC)=(90./PI)*(APLUS+AMINS)
              PHASEE(MC)=(0.25/PI)*TCP(MC)*(AMINS-APLUS)
              IF(PHASEE(MC).LT.0.) PHASEE(MC)=PHASEE(MC)+TCP(MC)
            ENDDO
            WRITE(97,10)TITLE
            WRITE(97,15)CLSL(ML),ILLSHA(ML),JLLSHA(ML),K
            WRITE(97,17)UMEAN,VMEAN
            WRITE(97,24)
            DO M=1,MTIDE
              WRITE(97,25)SYMBOL(M),TCP(M),AMPU(M),PHASEU(M),AMPV(M)
     &            ,PHASEV(M)
            ENDDO
            WRITE(97,13)
            WRITE(97,26)
            DO M=1,MTIDE
              WRITE(97,25)SYMBOL(M),TCP(M),RMAJ(M),RMIN(M),ACCWX(M)
     &            ,PHASEE(M)
            ENDDO
            WRITE(97,41)
            DO M=1,MTIDE
              WRITE(97,40)RMAJ(M)
            ENDDO
            WRITE(97,41)
            DO MC=1,MTIDE
              WRITE(97,40)RMIN(M)
            ENDDO
            WRITE(97,41)
            DO MC=1,MTIDE
              WRITE(97,40)ACCWX(M)
            ENDDO
            WRITE(97,41)
            DO MC=1,MTIDE
              PPPTMP(M)=PHASEE(M)/3600.
              WRITE(97,40)PPPTMP(MC)
            ENDDO
            WRITE(97,13)
          ENDDO
        ENDIF
      ENDDO
      GOTO 501
  500 CONTINUE
C
C *** COMPUTE SOLUTION WITH TREND REMOVAL
C *** COMPUTE TREND
C
      DET=RMLSHA*RTTLSHA-RTLSHA*RTLSHA
      DO ML=1,MLLSHA
        P0(ML)=(PLSHA(ML)*RTTLSHA-PTLSHA(ML)*RTLSHA)/DET
        P1DT1(ML)=(PTLSHA(ML)*RMLSHA-PLSHA(ML)*RTLSHA)/DET
        UE0(ML)=(UELSHA(ML)*RTTLSHA-UETLSHA(ML)*RTLSHA)/DET
        UE1DT1(ML)=(UETLSHA(ML)*RMLSHA-UELSHA(ML)*RTLSHA)/DET
        VE0(ML)=(VELSHA(ML)*RTTLSHA-VETLSHA(ML)*RTLSHA)/DET
        VE1DT1(ML)=(VETLSHA(ML)*RMLSHA-VELSHA(ML)*RTLSHA)/DET
        DO K=1,KC
          B0(K,ML)=(BLSHA(K,ML)*RTTLSHA-BTLSHA(K,ML)*RTLSHA)/DET
          B1DT1(K,ML)=(BTLSHA(K,ML)*RMLSHA-BLSHA(K,ML)*RTLSHA)/DET
          U0(K,ML)=(ULSHA(K,ML)*RTTLSHA-UTLSHA(K,ML)*RTLSHA)/DET
          U1DT1(K,ML)=(UTLSHA(K,ML)*RMLSHA-ULSHA(K,ML)*RTLSHA)/DET
          V0(K,ML)=(VLSHA(K,ML)*RTTLSHA-VTLSHA(K,ML)*RTLSHA)/DET
          V1DT1(K,ML)=(VTLSHA(K,ML)*RMLSHA-VLSHA(K,ML)*RTLSHA)/DET
        ENDDO
      ENDDO
C
C *** LOAD GLOBAL COEFFICIENT MATRIX
C
      MG=2*MTIDE
      DO MC=1,MTIDE
        MCPP=MC+MTIDE
        DO MR=1,MTIDE
          MRPP=MR+MTIDE
          GLSHA(MR,MC)=CCLSHA(MR,MC)
          GLSHA(MRPP,MCPP)=SSLSHA(MR,MC)
          GLSHA(MR,MCPP)=CSLSHA(MR,MC)
          GLSHA(MRPP,MC)=SCLSHA(MR,MC)
        ENDDO
      ENDDO
C
C *** PERFORM SVD ON GLSHA
C
      CALL SVDCMP (GLSHA,MG,MG,MGM,MGM,WLSHA,VVLSHA)
      WRITE(97,10)TITRT
      WRITE(97,11)
      DO M=1,MG
        WRITE(97,12)WLSHA(M)
      ENDDO
      WRITE(97,13)
C
C *** SOLVE BY BACK SUBSTITUTION AND OUTPUT RESULTS
C
      TITLE='FREE SURFACE DISPLACEMENT, TREND REMOVED'
      DO ML=1,MLLSHA
        IF(LSHAP(ML).EQ.1)THEN
          WRITE(97,10)TITLE
          WRITE(97,14)CLSL(ML),ILLSHA(ML),JLLSHA(ML)
          WRITE(97,18)P0(ML)
          WRITE(97,19)P1DT1(ML)
          WRITE(97,22)
          DO MC=1,MTIDE
            MCPP=MC+MTIDE
            RHS(MC)=PCLSHA(ML,MC)-P0(ML)-P1DT1(ML)*CTLSHA(MC)
            RHS(MCPP)=PSLSHA(ML,MC)-P0(ML)-P1DT1(ML)*STLSHA(MC)
          ENDDO
          CALL SVBKSB (GLSHA,WLSHA,VVLSHA,MG,MG,MGM,MGM,RHS,RSOL)
          DO MC=1,MTIDE
            MCPP=MTIDE+MC
            AMP=SQRT(RSOL(MC)*RSOL(MC)
     &          +RSOL(MCPP)*RSOL(MCPP))
            IF(RSOL(MCPP).EQ.0.0.AND.RSOL(MC).EQ.0.0)THEN
              PHI=999999.
            ELSE
              PHI=ATAN2(RSOL(MCPP),RSOL(MC))
            ENDIF
            PHASE=TCP(MC)*PHI/PI2
            IF(PHASE.LT.0.) PHASE=PHASE+TCP(MC)
            AMATMP(MC)=AMP
            PPPTMP(MC)=PHASE/3600.
            WRITE(97,23)SYMBOL(MC),TCP(MC),AMP,PHASE
          ENDDO
          WRITE(97,41)
          DO MC=1,MTIDE
            WRITE(97,40)AMATMP(MC)
          ENDDO
          WRITE(97,41)
          DO MC=1,MTIDE
            WRITE(97,40)PPPTMP(MC)
          ENDDO
          WRITE(97,13)
        ENDIF
      ENDDO
      TITLE='SALINITY, TREND REMOVED'
      DO ML=1,MLLSHA
        IF(LSHAB(ML).EQ.1)THEN
          DO K=1,KC
            WRITE(97,10)TITLE
            WRITE(97,15)CLSL(ML),ILLSHA(ML),JLLSHA(ML),K
            WRITE(97,18)B0(K,ML)
            WRITE(97,19)B1DT1(K,ML)
            WRITE(97,22)
            DO MC=1,MTIDE
              MCPP=MC+MTIDE
              RHS(MC)=BCLSHA(K,ML,MC)-B0(K,ML)-B1DT1(K,ML)*CTLSHA(MC)
              RHS(MCPP)=BSLSHA(K,ML,MC)-B0(K,ML)-B1DT1(K,ML)*STLSHA(MC)
            ENDDO
            CALL SVBKSB (GLSHA,WLSHA,VVLSHA,MG,MG,MGM,MGM,RHS,RSOL)
            DO MC=1,MTIDE
              MCPP=MC+MTIDE
              AMP=SQRT(RSOL(MC)*RSOL(MC)
     &            +RSOL(MCPP)*RSOL(MCPP))
              IF(RSOL(MCPP).EQ.0.0.AND.RSOL(MC).EQ.0.0)THEN
                PHI=999999.
              ELSE
                PHI=ATAN2(RSOL(MCPP),RSOL(MC))
              ENDIF
              PHASE=TCP(MC)*PHI/PI2
              IF(PHASE.LT.0.) PHASE=PHASE+TCP(MC)
              AMATMP(MC)=AMP
              PPPTMP(MC)=PHASE/3600.
              WRITE(97,23)SYMBOL(MC),TCP(MC),AMP,PHASE
            ENDDO
            WRITE(97,41)
            DO MC=1,MTIDE
              WRITE(97,40)AMATMP(MC)
            ENDDO
            WRITE(97,41)
            DO MC=1,MTIDE
              WRITE(97,40)PPPTMP(MC)
            ENDDO
            WRITE(97,13)
          ENDDO
        ENDIF
      ENDDO
      TITLE='HORIZONTAL EXTERNAL MODE VELOCITY, TREND REMOVED'
      DO ML=1,MLLSHA
        IF(LSHAU(ML).EQ.1)THEN
          DO MC=1,MTIDE
            MCPP=MC+MTIDE
            RHS(MC)=UECLSHA(ML,MC)-UE0(ML)-UE1DT1(ML)*CTLSHA(MC)
            RHS(MCPP)=UESLSHA(ML,MC)-UE0(ML)-UE1DT1(ML)*STLSHA(MC)
          ENDDO
          CALL SVBKSB (GLSHA,WLSHA,VVLSHA,MG,MG,MGM,MGM,RHS,RSOL)
          DO MC=1,MTIDE
            MCPP=MC+MTIDE
            AMPU(MC)=SQRT(RSOL(MC)*RSOL(MC)
     &          +RSOL(MCPP)*RSOL(MCPP))
            UCOS(MC)=RSOL(MC)
            USIN(MC)=RSOL(MCPP)
            IF(RSOL(MCPP).EQ.0.0.AND.RSOL(MC).EQ.0.0)THEN
              PHI=999999.
            ELSE
              PHI=ATAN2(RSOL(MCPP),RSOL(MC))
            ENDIF
            PHASEU(MC)=TCP(MC)*PHI/PI2
            IF(PHASEU(MC).LT.0.) PHASEU(MC)=PHASEU(MC)+TCP(MC)
          ENDDO
          DO MC=1,MTIDE
            MCPP=MC+MTIDE
            RHS(MC)=VECLSHA(ML,MC)-VE0(ML)-VE1DT1(ML)*CTLSHA(MC)
            RHS(MCPP)=VESLSHA(ML,MC)-UE0(ML)-VE1DT1(ML)*STLSHA(MC)
          ENDDO
          CALL SVBKSB (GLSHA,WLSHA,VVLSHA,MG,MG,MGM,MGM,RHS,RSOL)
          DO MC=1,MTIDE
            MCPP=MC+MTIDE
            AMPV(MC)=SQRT(RSOL(MC)*RSOL(MC)
     &          +RSOL(MCPP)*RSOL(MCPP))
            VCOS(MC)=RSOL(MC)
            VSIN(MC)=RSOL(MCPP)
            IF(RSOL(MCPP).EQ.0.0.AND.RSOL(MC).EQ.0.0)THEN
              PHI=999999.
            ELSE
              PHI=ATAN2(RSOL(MCPP),RSOL(MC))
            ENDIF
            PHASEV(MC)=TCP(MC)*PHI/PI2
            IF(PHASEV(MC).LT.0.) PHASEV(MC)=PHASEV(MC)+TCP(MC)
          ENDDO
          DO MC=1,MTIDE
            TERM1=UCOS(MC)+VSIN(MC)
            TERM2=VCOS(MC)-USIN(MC)
            TERM3=UCOS(MC)-VSIN(MC)
            TERM4=VCOS(MC)+USIN(MC)
            RPLUS=0.5*SQRT(TERM1*TERM1+TERM2*TERM2)
            RMINS=0.5*SQRT(TERM3*TERM3+TERM4*TERM4)
            IF(TERM1.EQ.0.0.AND.TERM2.EQ.0.0)THEN
              APLUS=999999.
            ELSE
              APLUS=ATAN2(TERM2,TERM1)
            ENDIF
            IF(TERM3.EQ.0.0.AND.TERM4.EQ.0.0)THEN
              AMINS=999999.
            ELSE
              AMINS=ATAN2(TERM4,TERM3)
            ENDIF
            RMAJ(MC)=RPLUS+RMINS
            RMIN(MC)=RPLUS-RMINS
            ACCWX(MC)=(90./PI)*(APLUS+AMINS)
            PHASEE(MC)=(0.25/PI)*TCP(MC)*(AMINS-APLUS)
            IF(PHASEE(MC).LT.0.) PHASEE(MC)=PHASEE(MC)+TCP(MC)
          ENDDO
          WRITE(97,10)TITLE
          WRITE(97,14)CLSL(ML),ILLSHA(ML),JLLSHA(ML)
          WRITE(97,20)UE0(ML),VE0(ML)
          WRITE(97,21)UE1DT1(ML),VE1DT1(ML)
          WRITE(97,24)
          DO M=1,MTIDE
            WRITE(97,25)SYMBOL(M),TCP(M),AMPU(M),PHASEU(M),AMPV(M)
     &          ,PHASEV(M)
          ENDDO
          WRITE(97,13)
          WRITE(97,26)
          DO M=1,MTIDE
            WRITE(97,25)SYMBOL(M),TCP(M),RMAJ(M),RMIN(M),ACCWX(M)
     &          ,PHASEE(M)
          ENDDO
          WRITE(97,41)
          DO M=1,MTIDE
            WRITE(97,40)RMAJ(M)
          ENDDO
          WRITE(97,41)
          DO MC=1,MTIDE
            WRITE(97,40)RMIN(M)
          ENDDO
          WRITE(97,41)
          DO MC=1,MTIDE
            WRITE(97,40)ACCWX(M)
          ENDDO
          WRITE(97,41)
          DO MC=1,MTIDE
            PPPTMP(M)=PHASEE(M)/3600.
            WRITE(97,40)PPPTMP(MC)
          ENDDO
          WRITE(97,13)
        ENDIF
      ENDDO
      TITLE='HORIZONTAL VELOCITY, TREND REMOVED'
      DO ML=1,MLLSHA
        IF(LSHAU(ML).EQ.1)THEN
          DO K=1,KC
            DO MC=1,MTIDE
              MCPP=MC+MTIDE
              RHS(MC)=UCLSHA(K,ML,MC)-U0(K,ML)-U1DT1(K,ML)*CTLSHA(MC)
              RHS(MCPP)=USLSHA(K,ML,MC)-U0(K,ML)-U1DT1(K,ML)*STLSHA(MC)
            ENDDO
            CALL SVBKSB (GLSHA,WLSHA,VVLSHA,MG,MG,MGM,MGM,RHS,RSOL)
            DO MC=1,MTIDE
              MCPP=MC+MTIDE
              AMPU(MC)=SQRT(RSOL(MC)*RSOL(MC)
     &            +RSOL(MCPP)*RSOL(MCPP))
              UCOS(MC)=RSOL(MC)
              USIN(MC)=RSOL(MCPP)
              IF(RSOL(MCPP).EQ.0.0.AND.RSOL(MC).EQ.0.0)THEN
                PHI=999999.
              ELSE
                PHI=ATAN2(RSOL(MCPP),RSOL(MC))
              ENDIF
              PHASEU(MC)=TCP(MC)*PHI/PI2
              IF(PHASEU(MC).LT.0.) PHASEU(MC)=PHASEU(MC)+TCP(MC)
            ENDDO
            DO MC=1,MTIDE
              MCPP=MC+MTIDE
              RHS(MC)=VCLSHA(K,ML,MC)-V0(K,ML)-V1DT1(K,ML)*CTLSHA(MC)
              RHS(MCPP)=VSLSHA(K,ML,MC)-U0(K,ML)-V1DT1(K,ML)*STLSHA(MC)
            ENDDO
            CALL SVBKSB (GLSHA,WLSHA,VVLSHA,MG,MG,MGM,MGM,RHS,RSOL)
            DO MC=1,MTIDE
              MCPP=MC+MTIDE
              AMPV(MC)=SQRT(RSOL(MC)*RSOL(MC)
     &            +RSOL(MCPP)*RSOL(MCPP))
              VCOS(MC)=RSOL(MC)
              VSIN(MC)=RSOL(MCPP)
              IF(RSOL(MCPP).EQ.0.0.AND.RSOL(MC).EQ.0.0)THEN
                PHI=999999.
              ELSE
                PHI=ATAN2(RSOL(MCPP),RSOL(MC))
              ENDIF
              PHASEV(MC)=TCP(MC)*PHI/PI2
              IF(PHASEV(MC).LT.0.) PHASEV(MC)=PHASEV(MC)+TCP(MC)
            ENDDO
            DO MC=1,MTIDE
              TERM1=UCOS(MC)+VSIN(MC)
              TERM2=VCOS(MC)-USIN(MC)
              TERM3=UCOS(MC)-VSIN(MC)
              TERM4=VCOS(MC)+USIN(MC)
              RPLUS=0.5*SQRT(TERM1*TERM1+TERM2*TERM2)
              RMINS=0.5*SQRT(TERM3*TERM3+TERM4*TERM4)
              IF(TERM1.EQ.0.0.AND.TERM2.EQ.0.0)THEN
                APLUS=999999.
              ELSE
                APLUS=ATAN2(TERM2,TERM1)
              ENDIF
              IF(TERM3.EQ.0.0.AND.TERM4.EQ.0.0)THEN
                AMINS=999999.
              ELSE
                AMINS=ATAN2(TERM4,TERM3)
              ENDIF
              RMAJ(MC)=RPLUS+RMINS
              RMIN(MC)=RPLUS-RMINS
              ACCWX(MC)=(90./PI)*(APLUS+AMINS)
              PHASEE(MC)=(0.25/PI)*TCP(MC)*(AMINS-APLUS)
              IF(PHASEE(MC).LT.0.) PHASEE(MC)=PHASEE(MC)+TCP(MC)
            ENDDO
            WRITE(97,10)TITLE
            WRITE(97,15)CLSL(ML),ILLSHA(ML),JLLSHA(ML),K
            WRITE(97,20)U0(K,ML),V0(K,ML)
            WRITE(97,21)U1DT1(K,ML),V1DT1(K,ML)
            WRITE(97,24)
            DO M=1,MTIDE
              WRITE(97,25)SYMBOL(M),TCP(M),AMPU(M),PHASEU(M),AMPV(M)
     &            ,PHASEV(M)
            ENDDO
            WRITE(97,13)
            WRITE(97,26)
            DO M=1,MTIDE
              WRITE(97,25)SYMBOL(M),TCP(M),RMAJ(M),RMIN(M),ACCWX(M)
     &            ,PHASEE(M)
            ENDDO
            WRITE(97,41)
            DO M=1,MTIDE
              WRITE(97,40)RMAJ(M)
            ENDDO
            WRITE(97,41)
            DO MC=1,MTIDE
              WRITE(97,40)RMIN(M)
            ENDDO
            WRITE(97,41)
            DO MC=1,MTIDE
              WRITE(97,40)ACCWX(M)
            ENDDO
            WRITE(97,41)
            DO MC=1,MTIDE
              PPPTMP(M)=PHASEE(M)/3600.
              WRITE(97,40)PPPTMP(MC)
            ENDDO
            WRITE(97,13)
          ENDDO
        ENDIF
      ENDDO
   10 FORMAT(1X,A80,//)
   11 FORMAT('  SINGULAR VALUES',//)
   12 FORMAT(1X,E12.4)
   13 FORMAT(////)
   14 FORMAT(1X,A20,4X,'I=',I5,4X,'J=',I5,//)
   15 FORMAT(1X,A20,4X,'I=',I5,4X,'J=',I5,4X,'K=',I5,//)
   16 FORMAT('  MEAN=',2X,E12.4,//)
   17 FORMAT('  U MEAN=',2X,E12.4,4X,'V MEAN=',2X,E12.4,//)
   18 FORMAT('  INTERSEPT=',2X,E12.4,//)
   19 FORMAT('  SLOPE=',2X,E12.4,//)
   20 FORMAT('  U INTERSEPT=',2X,E12.4,4X,'V INTERSEPT=',2X,E12.4,//)
   21 FORMAT('  U SLOPE=',2X,E12.4,4X,'V SLOPE=',2X,E12.4,//)
   22 FORMAT('  SYMBOL',3X,'TCP',12X,'AMPLITUDE',6X,'PHASE',/)
   23 FORMAT(1X,A5,3X,E12.4,3X,E12.4,3X,E12.4,/)
   24 FORMAT('  SYMBOL',3X,'TCP',12X,'AMU',12X,'PHU',12X,'AMV',
     &    12X,'PHV',/)
   25 FORMAT(1X,A5,3X,E12.4,3X,E12.4,3X,E12.4,3X,E12.4,3X,E12.4,/)
   26 FORMAT('  SYMBOL',3X,'TCP',12X,'MAJ',12X,'MIN',12X,'ANG',
     &    12X,'PHE',/)
   40 FORMAT(1X,F12.3)
   41 FORMAT(//)
   42 FORMAT(F10.0)
  230 FORMAT(4E14.5,4X,A2)
  501 CONTINUE
      CLOSE(97)
      RETURN
      END


!***********************************************************************************
    SUBROUTINE RandomPath()
    !c----------------------------------------------------------------------
    !c
    !c----------------------------------------------------------------------
    use varmod
    implicit none
    ! Declare local variables
    REAL , DIMENSION  (MAXXYZ) :: sim
    real , DIMENSION  (MAXXYZ) :: c,d,e,f,g,h
    integer::jx,jy,jz,ix,iy,iz,iix,iiy,iiz
    INTEGER :: ingd,ind

    CALL Random_Number(sim(:nxyzcoarse))

    DO ingd=1, nxycoarse
        jz=1
        jy=1+int((ingd-(jz-1)*nxycoarse-1)/nxcoarse)
        jx=ingd-(jz-1)*nxycoarse-(jy-1)*nxcoarse
        ix=(jx-1)*ncoarse+1
        iy=(jy-1)*ncoarse+1
        iz=(jz-1)*ncoarse+1

        ncnode=0
        do ind=1,nltemplate
            iix=ix+ixnode(ind)
            iiy=iy+iynode(ind)
            iiz=iz+iznode(ind)
            IF(iix>=1.and.iix<=nx.and.iiy>=1.and.iiy<=ny.and.iiz>=1.and.iiz<=nz) THEN
                IF(simim(iix,iiy,iiz)>UNEST) ncnode=ncnode+1
            end if
        end do
        order(ingd)=ingd
        sim(ingd)=sim(ingd)-ncnode
    end do
    CALL sortem(1,nxycoarse,sim,1,order,c,d,e,f,g,h)

    END SUBROUTINE RandomPath
    !***********************************************************************************


Program TimingAccuracyGLQ
!------------------------------------------------------------------------------
!
!    This program will test the accuracy of the spherical harmonic GLQ
!    tranformation routines by expanding a field in the space domain,
!    transforming this to spherical harmonics, and comparing the relative error
!    of the coefficients.
!
!    Copyright (c) 2005, SHTOOLS
!    All rights reserved.
!
!------------------------------------------------------------------------------
    use SHTOOLS
    use ftypes

    implicit none

    integer, parameter :: maxdeg = 2800
    character(200) :: outfile1, outfile2, outfile3, outfile4, outfile
    real(dp), allocatable :: cilm(:,:,:), cilm2(:,:,:), zero(:), &
                             gridglq(:,:), w(:)
    real(dp) :: maxerror, err1, err2, beta, rms, timein(3), timeout(3)
    integer :: lmax, l, m, seed, astat(5)

    allocate(cilm(2,maxdeg+1,maxdeg+1), stat=astat(1))
    allocate(cilm2(2,maxdeg+1,maxdeg+1), stat=astat(2))
    allocate(zero(maxdeg+1), stat=astat(3))
    allocate(gridglq(maxdeg+1,2*maxdeg+1), stat=astat(4))
    allocate(w(maxdeg+1), stat=astat(5))

    if (sum(astat(1:5)) /= 0) then
        print*, "Error --- TimingAccuracyGLQ"
        print*, "Problem allocating arrays CILM, CILM2, ZERO, GRIDGLQ, W"
        stop
    end if

    print*, "Value of beta for power law Sff = l^(-beta) > "
    read(*,*) beta

    print*, "output file name > "
    read(*,*) outfile

    outfile1 = trim(outfile) // ".timef"
    outfile2 = trim(outfile) // ".timei"
    outfile3 = trim(outfile) // ".maxerror"
    outfile4 = trim(outfile) // ".rmserror"

    seed = -1053253

    cilm = 0.0_dp

    do l = 1, maxdeg

        do m = 0, l
            if (m == 0) then
                cilm(1,l+1,m+1) = RandomGaussian(seed)
            else
                cilm(1,l+1,m+1) = RandomGaussian(seed)
                cilm(2,l+1,m+1) = RandomGaussian(seed)
            end if
        end do
        cilm(1:2, l+1, 1:l+1) = cilm(1:2, l+1, 1:l+1) * sqrt(dble(l)**beta) &
                                / sqrt(2.0_dp * l + 1)
    enddo

    print*, "Lmax, Maximum rel. error of Cilm, RMS relative error, Precompute time (sec), Time inverse (sec), Time forward (sec)"

    lmax = 1

    do

        lmax = lmax * 2
        if (lmax > maxdeg) lmax = maxdeg

        if (lmax == 2) then
            open(12,file=outfile1, status="replace")
            open(13,file=outfile2, status="replace")
            open(14,file=outfile3, status="replace")
            open(15,file=outfile4, status="replace")
        else
            open(12,file=outfile1, position="append")
            open(13,file=outfile2, position="append")
            open(14,file=outfile3, position="append")
            open(15,file=outfile4, position="append")
        endif

        call cpu_time(timein(1))
        call SHGLQ(lmax, zero(1:lmax+1), w(1:lmax+1))
        call cpu_time(timeout(1))

        call cpu_time(timein(2))
        call MakeGridGLQ(gridglq(1:lmax+1, 1:2*lmax+1), &
                         cilm(1:2,1:lmax+1, 1:lmax+1), lmax, &
                         zero=zero(1:lmax+1), norm=1)
        call cpu_time(timeout(2))

        call cpu_time(timein(3))
        call SHExpandGLQ(cilm2(1:2, 1:lmax+1, 1:lmax+1), lmax, &
                         gridglq(1:lmax+1, 1:2*lmax+1), w, &
                         zero=zero(1:lmax+1), norm=1)
        call cpu_time(timeout(3))

        maxerror = 0.0_dp
        rms = 0.0_dp

        do l = 1, lmax

            do m = 0, l
                if (m == 0) then
                    err1 = abs( (cilm(1,l+1,m+1) - cilm2(1,l+1,m+1)) / cilm(1,l+1,m+1) )
                    if (err1 >= maxerror) maxerror = err1
                    rms = rms + err1**2
                else
                    err1 = abs( (cilm(1,l+1,m+1) - cilm2(1,l+1,m+1)) / cilm(1,l+1,m+1) )
                    err2 = abs( (cilm(2,l+1,m+1) - cilm2(2,l+1,m+1)) / cilm(2,l+1,m+1) )
                    if (err1 >= maxerror) maxerror = err1
                    if (err2 >= maxerror) maxerror = err2
                    rms = rms + err1**2 + err2**2
                end if
            end do
        end do
        rms = sqrt(rms / dble(l+1)**2)

        ! elasped time in seconds!
        print*, lmax, maxerror, rms, timeout(1)-timein(1), timeout(2)-timein(2), timeout(3)-timein(3)
        write(12,*) lmax, timeout(2)-timein(2)
        write(13,*) lmax, timeout(3)-timein(3)
        write(14,*) lmax, maxerror
        write(15,*) lmax, rms

        if (maxerror > 100.0_dp) then
            print*, "TESTS FAILED"
            print*, "Degree = ", lmax
            print*, "Maximum relative error = ", maxerror
            close(12)
            close(13)
            close(14)
            close(15)
            stop
        end if

        close(12)
        close(13)
        close(14)
        close(15)

        if (lmax == maxdeg) exit

    enddo

end program TimingAccuracyGLQ


      FUNCTION BETA(Z,W)
      BETA=EXP(GAMMLN(Z)+GAMMLN(W)-GAMMLN(Z+W))
      RETURN
      END


      program testcalc
      implicit none
      real*8 eepdf_tilde_calc,eepdf_tilde
      real*8 x,Q2,jkb
      real*8 res_y,res_x,res_grid
      real*8 factor
      integer id
      x=1.00000000d0
      Q2=10d0*10d0
      read *,id
      do while (x .gt. 1.97d-4)
      res_x = eepdf_tilde_calc(x,Q2,id,11,11)
      res_grid = eepdf_tilde(x,Q2,id,11,11)
      print *,x,res_grid,res_x
      x=x*0.99999d0
      if (x.lt.0.99d0)then
      x=x*0.999d0
      endif
      enddo
      end program


!=======================================================================
      Subroutine YVAL(id, iw, mm, yv, ygr)
!=======================================================================
!
!     This routine computes the values of  r^mm f(r), f'(r), f''(r)
!     at the gaussian points of each interval, where f(r) is defined
!     by the spline expansion vector yv.
!
!     on entry
!     --------
!     id      indivates derivatives of f(r)        (=0,1,2)
!     iw      if iw > 0, results are weighted by gaussian coef.s
!     mm      integer defining the power of r
!     yv      the spline expansion vector for the funciton f(r)
!
!     on exit
!     -------
!     ygr     array of values of r^mm f(r) at the gaussian points
!             of each interval
!-----------------------------------------------------------------------

         USE spline_param
         USE spline_grid

         IMPLICIT NONE
         INTEGER, INTENT(in) :: id, iw, mm
         REAL(KIND=8), DIMENSION(ns), INTENT(in) :: yv
         REAL(KIND=8), DIMENSION(nv, ks), INTENT(out) :: ygr

         ! .. local variables

         INTEGER :: m, i, ith
         REAL(KIND=8), DIMENSION(nv, ks) :: gw

         if (mm .eq. 0) then
            gw = 1.d0
         elseif (mm .eq. 1) then
            gw = gr
         elseif (mm .eq. -1) then
            gw = grm
         elseif (mm .gt. 1) then
            gw = gr**mm
         elseif (mm .lt. -1) then
            gw = grm**(-mm)
         end if

         if (iw .ne. 0) gw = gw*grw

         ygr = 0.d0

         if (id .eq. 0) then

            do m = 1, ks
               do i = 1, nv
                  do ith = 1, ks
                     ygr(i, m) = ygr(i, m) + yv(i + ith - 1)*bsp(i, m, ith)*gw(i, m)
                  end do
               end do
            end do

         elseif (id .eq. 1 .or. id .eq. 2) then

            do m = 1, ks
               do i = 1, nv
                  do ith = 1, ks
                     ygr(i, m) = ygr(i, m) + yv(i + ith - 1)*bspd(i, m, ith, id)*gw(i, m)
                  end do
               end do
            end do

         end if

      End Subroutine YVAL


!------------------------------------------------------------------------------
!!  module: FFT engine
!------------------------------------------------------------------------------
!!
!! - last modified: fabien margairaz ( fabien.margairaz@gmail.com ), 20/05/2014
!!
!! - description:
!!  - this code uese the FFTW (version 3.x)
!!
!------------------------------------------------------------------------------
module fft_engine

  use parameters_IO

  implicit none

  include "fftw3.f"

  private

  ! wavelength in x and y
  real(rprec),allocatable,dimension(:),public :: kx,ky
  real(rprec),allocatable,dimension(:,:),public :: kkx,kky,kk2

  ! fftw plans for nx & ny variables
  integer*8,public :: planx,plany,planx2,plany2

  ! fftw plans for 3/2nx & 3/2ny varilabes
  integer*8,public :: planx_big,plany_big,planx2_big,plany2_big

  ! fftw plans for 2d varilabes
  integer*8,public :: plan2d_f,plan2d_b

  public :: fft_init

contains !=======================================================================

  !-----------------------------------------------------------------------------------
  !! subroutine: init_fft ()
  !-----------------------------------------------------------------------------------
  !!
  !! - last modified: fabien margairaz ( fabien.margairaz@gmail.com ), 20/05/2014
  !!
  !! - description:
  !!
  !-----------------------------------------------------------------------------------
  subroutine fft_init()

    implicit none

    real(rprec),dimension(nx) :: inx
    real(rprec),dimension(ny) :: iny
    complex(rprec),dimension(lhx) :: outx
    complex(rprec),dimension(lhy) :: outy

    real(rprec),dimension(nx2) :: inx_big
    real(rprec),dimension(ny2) :: iny_big
    complex(rprec),dimension(nx2/2+1) :: outx_big
    complex(rprec),dimension(ny2/2+1) :: outy_big

    real(rprec),dimension(nx,ny) :: in2d
    complex(rprec),dimension(lhx,ny) :: out2d

    !formulate the fft plans (forw, n0, n1, double in, complex out, flags)
    call dfftw_plan_dft_r2c_1d(planx,nx,inx,outx,fftw_estimate)
    call dfftw_plan_dft_r2c_1d(plany,ny,iny,outy,fftw_estimate)

    call dfftw_plan_dft_c2r_1d(planx2,nx,outx,inx,fftw_estimate)
    call dfftw_plan_dft_c2r_1d(plany2,ny,outy,iny,fftw_estimate)

    call dfftw_plan_dft_r2c_1d(planx_big,nx2,inx_big,outx_big,fftw_estimate)
    call dfftw_plan_dft_r2c_1d(plany_big,ny2,iny_big,outy_big,fftw_estimate)

    call dfftw_plan_dft_c2r_1d(planx2_big,nx2,outx_big,inx_big,fftw_estimate)
    call dfftw_plan_dft_c2r_1d(plany2_big,ny2,outy_big,iny_big,fftw_estimate)

    call dfftw_plan_dft_r2c_2d(plan2d_f,nx,ny,in2d,out2d,fftw_estimate)
    call dfftw_plan_dft_c2r_2d(plan2d_b,nx,ny,out2d,in2d,fftw_estimate)

    call build_wavenumbers()

    return
  end subroutine fft_init

  !-----------------------------------------------------------------------------------
  !! subroutine: build wavenumbers arrays in sprectral space
  !-----------------------------------------------------------------------------------
  !!
  !! - last modified: fabien margairaz ( fabien.margairaz@gmail.com ), 20/06/2014
  !!
  !! - description:
  !!  - kx&ky in sprectral space
  !!  - adds at nyquist freq values of kx, ky = 0 for the derivatives
  !!  - renormalizes the wavenumbers to take into account the real domain dimention
  !!
  !-----------------------------------------------------------------------------------
  subroutine build_wavenumbers ()

    implicit none

    integer :: status, errorcode
    integer i,j

    ! = 1D wavenumber ==========
    allocate(kx(lhx));allocate(ky(lhy))
    kx=0._rprec;ky=0._rprec;

    !fills kx starting from jx=0 to jx=nx/2 (the freq nx/2+1 is filled with 0 later)
    do i=1,lhx
       kx(i)=real(i-1,rprec)
    enddo
    do j=1,lhy
       ky(j)=real(j-1,rprec)
    enddo
    !eliminates the nyquist value to calculate a correct first derivative later
    kx(lhx)=0._rprec
    ky(lhy)=0._rprec
    !renormalization for the aspect ratio change
    kx=2._rprec*pi/lx*kx
    ky=2._rprec*pi/ly*ky

    ! = 2D wavenumber ==========
    allocate(kkx(lhx,ny));allocate(kky(lhx,ny));allocate(kk2(lhx,ny))
    kkx=0._rprec;kky=0._rprec;kk2=0._rprec

    !fills kx starting from jx=0 to jx=nx/2 (the freq nx/2+1 is filled with 0 later)
    do i=1,lhx
       kkx(i,:) = real(i-1,kind=rprec)
    end do
    do j=1,ny
       kky(:,j) = real(modulo(j - 1 + ny/2,ny) - ny/2, kind=rprec)
    end do

    ! eliminates the nyquist value to calculate a correct first derivative later
    kkx(lhx,:)=0._rprec
    kky(lhx,:)=0._rprec
    kkx(:,lhy)=0._rprec
    kky(:,lhy)=0._rprec
    ! renormalization for the aspect ratio change
    kkx=2._rprec*pi/lx*kkx
    kky=2._rprec*pi/ly*kky

    kk2 = kkx*kkx + kky*kky
    return
  end subroutine build_wavenumbers

end module fft_engine


PROGRAM hashord

!===SKIP, THIS IS THE ORDERED HASH PROGRAM I WAS TALKING ABOUT
!   AND PROMISED YOU A WHILE BACK... WELL HERE IT IS, HAVE FUN!!
!   S. W. WHARTON 2/5/83

! Code converted using TO_F90 by Alan Miller
! Date: 2000-03-26  Time: 09:35:46

IMPLICIT NONE
INTEGER :: i, ncell, nentry, nprobe, npts, nstat, nswap, rndseq(10000),  &
           tswap, tprobe, tfound

INTERFACE
  SUBROUTINE orhash(ncell, ENTRY, mode, STATUS, nprobe, nswap)
    IMPLICIT NONE
    INTEGER, INTENT(IN)   :: ncell
    INTEGER, INTENT(IN)   :: ENTRY
    INTEGER, INTENT(IN)   :: mode
    INTEGER, INTENT(OUT)  :: STATUS
    INTEGER, INTENT(OUT)  :: nprobe
    INTEGER, INTENT(OUT)  :: nswap
  END SUBROUTINE orhash
END INTERFACE

nentry = 450
ncell = 499
npts = 10000
CALL irand(rndseq, 10000, -30000, 30000)
tfound = 0
tprobe = 0
tswap = 0

!     ...ENTER NENTRY POINTS INTO THE ORDERED HASH TABLE
DO  i = 1, nentry
  CALL orhash(ncell, rndseq(i), 2, nstat, nprobe, nswap)
  IF (nstat /= 3) tfound = tfound + 1
  tswap = tswap + nswap
  tprobe = tprobe + nprobe
END DO
WRITE(6,600) nentry, tfound, tprobe, tswap
tfound = 0
tprobe = 0
tswap = 0

!     ...NOW LOOK UP NPTS POINTS IN THE HASH TABLE
!     ...THE ORDERED HASH IS MORE EFFICIENT FOR UNSUCCESSFUL SEARCHES
DO  i = 1, npts
  CALL orhash(ncell, rndseq(i), 1, nstat, nprobe, nswap)
  IF (nstat /= 3) tfound = tfound + 1
  tswap = tswap + nswap
  tprobe = tprobe + nprobe
END DO
WRITE(6,600) npts, tfound, tprobe, tswap
STOP
600 FORMAT(' N=', i10, '     NFOUND =', i10, '     TPROBES =', i10,  &
           '     TSWAPS =', i10)

CONTAINS

SUBROUTINE irand(randseq, n, low, high)
INTEGER, INTENT(OUT)  :: randseq(:)
INTEGER, INTENT(IN)   :: n, low, high

REAL    :: ran(n)

CALL RANDOM_NUMBER(ran)
randseq = low + (high + 1 - low) * ran

RETURN
END SUBROUTINE irand

END PROGRAM hashord

SUBROUTINE orhash(ncell, ENTRY, mode, STATUS, nprobe, nswap)
!=
!=    USE A HASH FUNCTION TO LOOK UP OR INSERT KEYS INTO A TABLE.
!=    ORHASH USES THE ORDERED HASHING ALGORITHM WITH PASS BITS BY AMBLE AND
!=    KNUTH, (1974) ORDERED HASH TABLES, COMPUTER JOURNAL 17(2):135-142.
!=
!=    ORDERED HASHING REDUCES THE NUMBER OF PROBES FOR UNSUCCESSFUL
!=    SEARCHING AND SO REDUCES THE SCANNER CPU TIME.
!=
!=    VARIABLE    DESCRIPTION
!=    --------    -----------
!=    NCELL       I - HASH TABLE LENGTH (PRIME NUMBER)
!=    NDIM        I - LENGTH OF EACH KEY
!=    ENTRY       I - NUMBER TO BE ENTERED OR PROBED FOR IN HASH TABLE
!=       NOTE: BECAUSE ORHASH MAY SWAP KEYS, ENTRY IS COPIED INTO KEY
!=             FOR SEARCHING.  NEGATIVE AND ZERO VALUES OF KEY ARE OK.
!=    MODE        I - IS GIVEN AS AN INDICATOR AS FOLLOWS...
!=          (1) - MEANS TO ONLY LOOK UP THE KEY IN TABLE
!=          (2) - MEANS LOOK UP AND ENTER KEY IF IT IS NOT YET IN TABLE
!=    STATUS      I - FINAL STATUS OF THE PROBE SEQUENCE AS FOLLOWS:
!=          (1) - THE KEY WAS ADDED TO THE HASH TABLE AS A NEW ENTRY
!=          (2) - THE KEY MATCHED AN ENTRY IN THE HASH TABLE
!=          (3) - THE KEY WAS NOT ENTERED NOR WAS A MATCH FOUND
!=    NPROBE      I - THE NUMBER OF PROBES NEEDED TO ENTER THE KEY.
!=    NSWAP       I - THE NUMBER OF SWAPS NEEDED TO ENTER KEY
!=
!=    COMMON BLOCKS:    (NONE)
!=    I/O DEVICE #'S:  INPUT - (NONE);  OUTPUT - (NONE)
!=

IMPLICIT NONE

INTEGER, INTENT(IN)   :: ncell
INTEGER, INTENT(IN)   :: ENTRY
INTEGER, INTENT(IN)   :: mode
INTEGER, INTENT(OUT)  :: STATUS
INTEGER, INTENT(OUT)  :: nprobe
INTEGER, INTENT(OUT)  :: nswap

INTEGER :: afp, i, ikey, iknt, inc, ka, key, keytab(5000), newknt

!     ...FOR ORHASH TO WORK PROPERLY, THE ARRAYS BINKNT AND PASSBT
!     ...MUST BE INITIALIZED TO ALL ZEROES AND FALSE, RESPECTIVELY.
! DATA binknt/005000*0/, passbt/005000*.false./
INTEGER, SAVE :: binknt(5000) = (/ (0, i=1,5000) /)
LOGICAL, SAVE :: passbt(5000) = (/ (.FALSE., i=1,5000) /)

key = ENTRY
newknt = 1
nprobe = 1
nswap = 0
STATUS = 3

!     ...COMPUTE ADDRESS OF FIRST PROBE (AFP) AND INCREMENT (INC).
afp = ABS(MOD(key,ncell))  + 1
inc = ABS(MOD(key,ncell-2))  + 1
ka = afp

!     ...BEGIN THE SEARCH LOOP TO FIND AN ENTRY IN THE ORDERED
!     ...HASH TABLE (KEYTAB) THAT MATCHES THE NEW KEY

!     ...EXIT SEARCH LOOP IF EMPTY LOCATION FOUND
10 IF( binknt(ka) == 0 ) GO TO 100

!        ...CHECK IF KEYTAB(KA) MATCHES THE KEY
IF( key /= keytab(ka) ) GO TO 20

!           ...A MATCH WAS FOUND, INCREMENT BIN COUNTER AND EXIT LOOP
binknt(ka) = binknt(ka) + 1
STATUS = 2
GO TO 999

!        ...EXIT SEARCH LOOP IF NO SMALLER ENTRIES FOLLOW KEYTAB(KA)
20 IF ( .NOT. passbt(ka) ) GO TO 100

!           ...EXIT SEARCH LOOP IF KEYTAB(KA) IS SMALLER THAN KEY
IF ( key > keytab(ka) ) GO TO 100

!              ...COMPUTE ADDRESS OF NEXT PROBE
ka = ka - inc
IF( ka < 1 ) ka = ka + ncell
nprobe = nprobe + 1
GO TO 10

!     ...BEGIN THE INSERTION LOOP TO ENTER THE NEW KEY IN THE
!     ...ORDERED HASH TABLE IN THE APPROPRIATE POSITION SUCH
!     ...THAT THE KEYS ARE ARRANGED IN DECREASING ORDER

!     ...TERMINATE HASHING IF NO ENTRIES ARE TO BE MADE (MODE=1)
100 IF( mode == 1 ) GO TO 999
110 IF( binknt(ka) /= 0 ) GO TO 120

!        ...LOAD KEY INTO EMPTY SPACE AT POSITION KA
binknt(ka) = newknt
keytab(ka) = key
STATUS = 1
GO TO 999

120 IF( key <= keytab(ka) ) GO TO 130

!        ...SWAP KEY WITH KEYTAB(KA) SO THAT THE KEYS ALONG A GIVEN
!        ...SEARCH SEQUENCE ARE ARRANGED IN DECREASING ORDER
ikey = key
key = keytab(ka)
keytab(ka) = ikey
iknt = newknt
newknt = binknt(ka)
binknt(ka) = iknt
nswap = nswap + 1
inc = ABS(MOD(key,ncell-2)) + 1
130   passbt(ka) = .true.

!     ...COMPUTE ADDRESS OF NEXT PROBE.
ka = ka - inc
IF( ka < 1 ) ka = ka + ncell
nprobe = nprobe + 1
GO TO 110

999 RETURN
END SUBROUTINE orhash


! { dg-do compile }
! { dg-options "-O2 -fbounds-check -ffast-math" }
  FUNCTION pw_integral_aa ( cc ) RESULT ( integral_value )
    COMPLEX(KIND=8), DIMENSION(:), POINTER :: cc
    integral_value = accurate_sum ( CONJG ( cc (:) ) * cc (:) )
  END FUNCTION pw_integral_aa


! Demonstrates parametric polymorphism through functions-calling-functions.
program squarePoly
  implicit none
  real :: x
  real :: y

  != unit(m) :: a
  real :: a
  != unit(s) :: b
  real :: b

  x = squareP(a)
  y = squareP(x)

  contains

  real function square(x)
    real :: x
    square = x * x
  end function

  real function squareP(x)
    real :: x
    squareP = square(x)
  end function

end program


!===============================================================================
! One of Andy Nowacki's Fortran utility modules for dealing with seismic
! anisotropy and other problems.
!
! Andy Nowacki <andy.nowacki@bristol.ac.uk>
!
! See the file LICENCE for licence details.
!===============================================================================
program step_prog
! Computes the endpoint given a starting point lon,lat, azimuth and angular distance

use spherical_geometry, only: step

implicit none

integer, parameter :: rs = selected_real_kind(15,307) ! DP
real(rs) :: lon1,lat1,lon2,lat2,az,delta
real(rs), parameter :: pi=3.14159265358979323846264338327950288D0
integer :: iostatus

if (command_argument_count() /= 0) then
	write(0,'(a)') 'Usage: step < [lon] [lat] [azi] [delta]',&
                  'Reads a list of values from stdin and writes the endpoint lon,lat to stdout.'
	stop
endif

iostatus = 0
do while (iostatus == 0)
	read(*,*,iostat=iostatus) lon1,lat1,az,delta
	if (iostatus < 0) exit
	if (iostatus > 0) stop 'step: Error: Problem reading lon,lat,azimuth,distance from stdin.'

	if (delta > 180.) then
		write(0,*) 'step: Error: distance must be less than 180 degrees.'
      stop
	else if (lat1 <  -90._rs .or. lat1 >  90._rs) then
		write(0,*) 'step: Error: latitude must be in range -90 - 90.'
      stop
   endif
   call step(lon1,lat1,az,delta,lon2,lat2,degrees=.true.)
	write(*,'(f11.4,f10.4)') lon2,lat2
enddo

end program step_prog


Subroutine LocPointsBC &
    (AE, BE, MaxLRows, XLL, NDim, iDofT, NodELT, Sol0, Sol1, CommonPar, Param, JParam, DelT, DTm, Time)

	use funcAux

    implicit none

    !   ===== SUBROUTINE ARGUMENTS  =======
    integer :: MaxLRows,Ndim,iDofT,NodELT ! all integers
    Real*8 :: DelT, DTm,Time ! all reals
    Real*8 :: AE(MaxLRows,MaxLRows), BE(MaxLRows), XLL(*), Sol0(*), Sol1(*), Param(*), JParam(*), CommonPar(*)

    !   =====   END ARGUMENTS  =======
    integer, parameter :: NdimE = 2
    integer :: i , ipLag, ipDeltaU, iShiftLag, iShiftDeltaU, iShiftFlagLoc
    Real*8 ::  pen, eps
    logical :: locActive

	iShiftDeltaU = nint(commonPar(1))
	iShiftLag = nint(commonPar(2))
	iShiftFlagLoc = nint(CommonPar(3)) ! in geometrical nodes

	pen = 1.0d5
	eps = 1.0d-10

	locActive = .false.
!~ 	write(*,*) Sol0( iShiftFlagLoc + 1)

	if(Sol0( iShiftFlagLoc + 1) > 0.0d0) locActive = .true.

	do i = 1 , NdimE
		ipLag = iShiftLag + i
		ipDeltaU = iShiftDeltaU + i

		if(locActive) then
			AE(ipLag, ipDeltaU) = pen
			AE(ipDeltaU , ipLag ) = 1.0d0
!~ 			AE(ipDeltaU, ipDeltaU) = pen
			AE(ipLag , ipLag ) = eps
			BE(ipLag ) = eps*Sol1(ipLag )
!~ 				BE(ipLag) = 0.0d0

!~ 			write(*,*) "is active"
		else
			AE(ipLag , ipLag) = eps
!~ 			write(*,*) "is not active"
		end if
	end do

end subroutine

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Subroutine LocPointsBCS(Coupling,CommonPar,iDofT,Ndim,MaxLRows,iAdd)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    use funcAux

    implicit none

    Integer :: MaxLRows,Ndim,iDofT, iAdd
    Integer ::  Coupling(MaxLRows,MaxLRows)
    Real*8 :: CommonPar(*), eps
    integer, parameter :: NdimE = 2
    integer :: iShiftLag, iShiftDeltaU, i,  ipLag, ipDeltaU

	iShiftDeltaU = nint(commonPar(1))
	iShiftLag = nint(commonPar(2))

	do i = 1 , NdimE
		ipLag = iShiftLag + i
		ipDeltaU = iShiftDeltaU + i

		Coupling(ipLag,ipLag) = 1
		Coupling(ipDeltaU,ipLag) = 1
		Coupling(ipLag,ipDeltaU) = 1
!~ 		Coupling(ipDeltaU,ipDeltaU) = 1

	end do

end Subroutine


program array_elements
    implicit none
    integer, dimension(5) :: A
    integer :: i

    A(1) = 1
    do i = 2, size(A)
        A(i)  = 2*A(i - 1)
    end do
    print *, A
end program array_elements


*=======================================================================
* File:    tmtest3.f
* Author:  Alex Stivala
* Created: July 2008
*
* Test program for tmatn.f
*
* $Id: tmtss3.f 2968 2009-11-22 01:21:50Z astivala $
*=======================================================================

      program tmtest3

      implicit none

      external tmatn

      integer n1,n2,info
      parameter(n1 = 7, n2 = 6)
      double precision omega1(n1,n1),omega2(n2,n2)
      double precision dmat1(n1,n1),dmat2(n2,n2)
      double precision score
      double precision soln(n1*n2+n1+n2)

*     MATLAB GetTableau('1ABA')
      data omega1  / 0d0,  -2.8600d0,  -0.3600d0,  -2.2100d0,
     $     2.9200d0,  -0.8100d0,  -2.7700d0,
     $     -2.8600d0,   1.0000d0,  -2.9100d0,   1.1200d0,
     $     -0.4500d0,   2.1300d0,   0.3300,
     $     -0.3600d0,  -2.9100d0,        0d0,  -2.1800d0,   2.5600d0,
     $     -1.1600d0,  -0.1200d0,
     $     -2.2100d0,   1.1200d0,  -2.1800d0,
     $     1.0000d0,   1.0200d0,  -1.8800d0,   0.8400d0,
     $     2.9200d0,  -0.4500d0,   2.5600d0,
     $     1.0200d0,        0d0,   2.5600d0,   0.6000d0,
     $     -0.8100d0,   2.1300d0,  -1.1600d0,
     $     -1.8800d0,   2.5600d0,        0d0,   1.9700d0,
     $     -2.7700d0,   0.3300d0,  -0.1200d0,
     $     0.8400d0,   0.6000d0,   1.9700d0,   1.0000d0/

*     MATLAB GetTableau('1UBQ')
      data omega2 / 0d0, 2.6500d0,  -1.1700d0, 2.0600d0, -1.2600d0,
     $     -0.5900d0,
     $     2.6500d0,    0d0, 2.1400d0,  -1.4300d0, 1.5700d0, 2.1000d0,
     $     -1.1700d0, 2.1400d0, 1.0000d0, 2.0900d0,  -1.0400d0,
     $     -1.2200d0,
     $     2.0600d0,  -1.4300d0, 2.0900d0,    0d0, 2.9600d0, 2.5800d0,
     $     -1.2600d0, 1.5700d0,  -1.0400d0, 2.9600d0,
     $     0d0,  -0.7400d0,
     $     -0.5900d0, 2.1000d0,  -1.2200d0, 2.5800d0,  -0.7400d0,  0d0/

      data dmat1 / 0, 0, 0, 0, 0, 0, 0,
     $             0, 0, 0, 0, 0, 0, 0,
     $             0, 0, 0, 0, 0, 0, 0,
     $             0, 0, 0, 0, 0, 0, 0,
     $             0, 0, 0, 0, 0, 0, 0,
     $             0, 0, 0, 0, 0, 0, 0,
     $             0, 0, 0, 0, 0, 0, 0 /

      data dmat2 / 0, 0, 0, 0, 0, 0,
     $             0, 0, 0, 0, 0, 0,
     $             0, 0, 0, 0, 0, 0,
     $             0, 0, 0, 0, 0, 0,
     $             0, 0, 0, 0, 0, 0,
     $             0, 0, 0, 0, 0, 0 /

*     should get score approx -4 (MATLAB TableauMatch -4.3232 or -4.5832)
*     -3.5124 when not using diagnoal elements

      call tmatn(omega1, n1, n1, omega2, n2, n2, .false., .false.,
     $           dmat1, dmat2,
     $           score, soln, info)
      if (info .ne. 0) then
         write(*,*),'TABMATN FAILED'
      else
         write(*,900),score
 900     format('score = ',f6.2)
      endif
      end


! { dg-do run }
!
! basic tests of PROCEDURE POINTERS
!
! Contributed by Janus Weil <janus@gcc.gnu.org>

module m
contains
  subroutine proc1(arg)
    character (5) :: arg
    arg = "proc1"
  end subroutine
  integer function proc2(arg)
    integer, intent(in) :: arg
    proc2 = arg**2
  end function
  complex function proc3(re, im)
    real, intent(in) :: re, im
    proc3 = complex (re, im)
  end function
end module

subroutine foo1
end subroutine

real function foo2()
  foo2=6.3
end function

program procPtrTest
  use m, only: proc1, proc2, proc3
  character (5) :: str
  PROCEDURE(proc1), POINTER :: ptr1
  PROCEDURE(proc2), POINTER :: ptr2
  PROCEDURE(proc3), POINTER :: ptr3 => NULL()
  PROCEDURE(REAL), SAVE, POINTER :: ptr4
  PROCEDURE(), POINTER :: ptr5,ptr6

  EXTERNAL :: foo1,foo2
  real :: foo2

  if(ASSOCIATED(ptr3)) call abort()

  NULLIFY(ptr1)
  if (ASSOCIATED(ptr1)) call abort()
  ptr1 => proc1
  if (.not. ASSOCIATED(ptr1)) call abort()
  call ptr1 (str)
  if (str .ne. "proc1") call abort ()

  ptr2 => NULL()
  if (ASSOCIATED(ptr2)) call abort()
  ptr2 => proc2
  if (.not. ASSOCIATED(ptr2,proc2)) call abort()
  if (10*ptr2 (10) .ne. 1000) call abort ()

  ptr3 => NULL (ptr3)
  if (ASSOCIATED(ptr3)) call abort()
  ptr3 => proc3
  if (ptr3 (1.0, 2.0) .ne. (1.0, 2.0)) call abort ()

  ptr4 => cos
  if (ptr4(0.0)/=1.0) call abort()

  ptr5 => foo1
  call ptr5()

  ptr6 => foo2
  if (ptr6()/=6.3) call abort()

end program

! { dg-final { cleanup-modules "m" } }


module math_func_interface
    implicit none

    interface
        function math_func(x) result(r)
            use, intrinsic :: iso_fortran_env, only : REAL64
            real(kind=REAL64), intent(in) :: x
            real(kind=REAL64) :: r
        end function math_func
    end interface

end module math_func_interface


program rstest
  use flips

  ! This program tests flips_resize in different situations
  ! Single precision real version

  implicit none

  type(flips_d) :: s1, s2

  real(dp), dimension(:), allocatable :: amat
  real(dp), dimension(:), allocatable :: meas,erro
  logical, dimension(:), allocatable :: re
  real(dp) :: diff, maxdiff
  real(dp) :: ts,te
  logical, dimension(:), allocatable :: remo

  write(*,*) 'Test 1: Marginalize 500 first unknowns from a 1000 unknowns problem'
  ! ********************************************************************

  write(*,*) '  Memory storage'

  ! Initialize s1
  call flips_init(s1,1000,1,buffersize=50)

  ! Create data
  allocate(amat(1000*1000),meas(1000),erro(1000))
  call random_number(amat)
  call random_number(meas)
  call random_number(erro)
  erro = erro + 0.5

  ! Feed data in s1
  call flips_add(s1,1000,amat,meas,erro)

  call cpu_time(ts)
  ! Resize by marginalizing 500 first unknowns

  call flips_resize(s2,s1,newsize=500)
  call cpu_time(te)

  ! Solve both problems
  call flips_solve(s1)

  call flips_solve(s2)

!write(*,*) s1%solmat(501:505)
!write(*,*) s2%solmat(1:5)

  ! Compare results
  diff = sum(s2%solmat - s1%solmat(501:1000))/500
  maxdiff = maxval(s2%solmat - s1%solmat(501:1000))
  write(*,*) '    Mean diff:',diff
  write(*,*) '    Max diff:',maxdiff
  write(*,*) '    Resize time:',te-ts,'\n'

  call flips_kill(s1,.FALSE.)
  call flips_kill(s2,.FALSE.)
  deallocate(amat,meas,erro)

write(*,*) '  File storage'

  ! Initialize s1
  call flips_init(s1,1000,1,idnum=1,buffersize=50)

  ! Create data
  allocate(amat(1000*1000),meas(1000),erro(1000))
  call random_number(amat)
  call random_number(meas)
  call random_number(erro)
  erro = erro + 0.5

  ! Feed data in s1
  call flips_add(s1,1000,amat,meas,erro)

  call cpu_time(ts)
  ! Resize by marginalizing 500 first unknowns
  call flips_resize(s2,s1,newsize=500,idnum=2)
  call cpu_time(te)

  ! Solve both problems
  call flips_solve(s1)
  call flips_solve(s2)

  ! Read results from file
  read(113,pos=1) meas
  read(213,pos=1) erro(1:500)

!write(*,*) meas(501:505)
!write(*,*) erro(1:5)

  ! Compare results
  diff = sum(erro(1:500) - meas(501:1000))/500
  maxdiff = maxval(erro(1:500) - meas(501:1000))
  write(*,*) '    Mean diff:',diff
  write(*,*) '    Max diff:',maxdiff
  write(*,*) '    Resize time:',te-ts,'\n'

  call flips_kill(s1,keepfiles=.FALSE.)
  call flips_kill(s2,keepfiles=.FALSE.)
  deallocate(amat,meas,erro)

write(*,*) 'Test 2: Remove last 500 unknowns from a 1000 unknowns problem'

 write(*,*) '  Memory storage'

  ! Initialize s1
  call flips_init(s1,1000,1,buffersize=50)

  ! Create data
  allocate(amat(1000*1000),meas(1000),erro(1000),remo(1000))
  call random_number(amat)
  call random_number(meas)
  call random_number(erro)
  erro = erro + 0.5
  remo = .FALSE.
  remo(501:1000) = .TRUE.

  ! Feed data in s1
  call flips_add(s1,1000,amat,meas,erro)

  call cpu_time(ts)
  ! Resize by marginalizing last 500 unknowns
  call flips_resize(s2,s1,remove=remo)
  call cpu_time(te)

  ! Solve both problems
  call flips_solve(s1)

  call flips_solve(s2)

!write(*,*) s1%solmat(501:505)
!write(*,*) s2%solmat(1:5)

  ! Compare results
  diff = sum(s2%solmat - s1%solmat(1:500))/500
  maxdiff = maxval(s2%solmat - s1%solmat(1:500))
  write(*,*) '    Mean diff:',diff
  write(*,*) '    Max diff:',maxdiff
  write(*,*) '    Resize time:',te-ts,'\n'

  call flips_kill(s1,.FALSE.)
  call flips_kill(s2,.FALSE.)
  deallocate(amat,meas,erro,remo)

 write(*,*) '  File storage'

  ! Initialize s1
  call flips_init(s1,1000,1,idnum=1,buffersize=50)

  ! Create data
  allocate(amat(1000*1000),meas(1000),erro(1000),remo(1000))
  call random_number(amat)
  call random_number(meas)
  call random_number(erro)
  erro = erro + 0.5
  remo = .FALSE.
  remo(501:1000) = .TRUE.

  ! Feed data in s1
  call flips_add(s1,1000,amat,meas,erro)

  call cpu_time(ts)
  ! Resize by marginalizing last 500 unknowns
  call flips_resize(s2,s1,remove=remo,idnum=2)
  call cpu_time(te)

!write(*,*) '!!'

  ! Solve both problems
  call flips_solve(s1)

!write(*,*) 's1'

  call flips_solve(s2)

!write(*,*) 's2'
  ! Read results from file
  read(113,pos=1) meas
  read(213,pos=1) erro(1:500)

!write(*,*) meas(501:505)
!write(*,*) erro(1:5)

  ! Compare results
  diff = sum(erro(1:500) - meas(1:500))/500
  maxdiff = maxval(erro(1:500) - meas(1:500))
  write(*,*) '    Mean diff:',diff
  write(*,*) '    Max diff:',maxdiff
  write(*,*) '    Resize time:',te-ts,'\n'

  call flips_kill(s1,.FALSE.)
  call flips_kill(s2,.FALSE.)
  deallocate(amat,meas,erro,remo)

end program rstest


*> \brief \b IZMAX1 finds the index of the first vector element of maximum absolute value.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download IZMAX1 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       INTEGER          FUNCTION IZMAX1( N, ZX, INCX )
*
*       .. Scalar Arguments ..
*       INTEGER            INCX, N
*       ..
*       .. Array Arguments ..
*       COMPLEX*16         ZX( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> IZMAX1 finds the index of the first vector element of maximum absolute value.
*>
*> Based on IZAMAX from Level 1 BLAS.
*> The change is to use the 'genuine' absolute value.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of elements in the vector ZX.
*> \endverbatim
*>
*> \param[in] ZX
*> \verbatim
*>          ZX is COMPLEX*16 array, dimension (N)
*>          The vector ZX. The IZMAX1 function returns the index of its first
*>          element of maximum absolute value.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*>          INCX is INTEGER
*>          The spacing between successive values of ZX.  INCX >= 1.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date February 2014
*
*> \ingroup complexOTHERauxiliary
*
*> \par Contributors:
*  ==================
*>
*> Nick Higham for use with ZLACON.
*
*  =====================================================================
      INTEGER FUNCTION IZMAX1( N, ZX, INCX )
*
*  -- LAPACK auxiliary routine (version 3.6.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     February 2014
*
*     .. Scalar Arguments ..
      INTEGER            INCX, N
*     ..
*     .. Array Arguments ..
      COMPLEX*16         ZX(*)
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      DOUBLE PRECISION   DMAX
      INTEGER            I, IX
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS
*     ..
*     .. Executable Statements ..
*
      IZMAX1 = 0
      IF (N.LT.1 .OR. INCX.LE.0) RETURN
      IZMAX1 = 1
      IF (N.EQ.1) RETURN
      IF (INCX.EQ.1) THEN
*
*        code for increment equal to 1
*
         DMAX = ABS(ZX(1))
         DO I = 2,N
            IF (ABS(ZX(I)).GT.DMAX) THEN
               IZMAX1 = I
               DMAX = ABS(ZX(I))
            END IF
         END DO
      ELSE
*
*        code for increment not equal to 1
*
         IX = 1
         DMAX = ABS(ZX(1))
         IX = IX + INCX
         DO I = 2,N
            IF (ABS(ZX(IX)).GT.DMAX) THEN
               IZMAX1 = I
               DMAX = ABS(ZX(IX))
            END IF
            IX = IX + INCX
         END DO
      END IF
      RETURN
*
*     End of IZMAX1
*
      END


C
C
      PROGRAM EVAL
C
C     Programme de test pour l'evaluation partielle et le
C     remplacement de constantes.
C
      INTEGER L(10)
C
C
      I=0
      J=1
      K=5
C
C     do not replace array references, but array indices
      L(I+J+1)=L(1)+L(J-0)+I
C
      DO I = J, K+0, J
         P=P+I
      ENDDO
C
      IF ((2*N*J-0) .GT. 0) THEN
         P=0
      END IF
C
C     test de PLUS et MINUS
      K= 2*M + 2*N
      K= 2*M - 2*N
      K= 2*M + (-2)*N
      K= -2*M + 2*N
      K= -2*M - 2*N
      K= -2*M + (-2)*N
C
      K= M + 2*N
      K= M - 2*N
      K= M +(-2)*N
      K= -M - 2*N
      K= -M +(-2)*N
      K= -M -(-2)*N
C
      K= 1 + N
      K= -1 -N
      K= -N -1
      K= -N + (-1)
      K= N + 1
      K= 0+N-0
C
C     test pour MULT
      K= 3*M*(-2)
      K= 1*N
      K= (2*N+1)*0
      K= (3*N)*M
      K= 2+((3*N+0)*(M-1) + 5)
      K= (N+1)*M
C
C     test pour DIV et MOD.
C     {A=3/2} est equivalent a {A=1}, mais different de {A=3./2}
      A= 3/2
      A= 3./2
      K= 3/2
      K= 4/2
      K= (-5)/(-2)
c     (-5)/2 = 5/(-2) = -2
      K= (-5)/2
      K= 5/(-2)
      K= (4*M+5)/2
      K= (4*M+5)/1
      K= (4*M+6)/2
c     MOD(3,2) = 1
      K1= MOD(3,2)
c     MOD(-3,-2) = -1
      K2= MOD(-3,-2)
C     Not true with gfortran
c     MOD(-3,2) = MOD(3,-2) = -1
c     MOD(-3,2) = -1
      K3= MOD(-3,2)
c     MOD(3,-2) = 1
      K4= MOD(3,-2)
      print *, k1, k2, k3, k4, "(should be 1, -1, -1, 1)"
C
C     do not replace written parameters of assign, fonctions
C     or subroutines!
      I=10
      I=I
      J=0
      call fx(I, J)
C
      END

      subroutine fx(NR, NW)
      NW=NR+1
      end


! -----------------------------------------------------------------
! Programmer(s): Cody J. Balos @ LLNL
! -----------------------------------------------------------------
! SUNDIALS Copyright Start
! Copyright (c) 2002-2019, Lawrence Livermore National Security
! and Southern Methodist University.
! All rights reserved.
!
! See the top-level LICENSE and NOTICE files for details.
!
! SPDX-License-Identifier: BSD-3-Clause
! SUNDIALS Copyright End
! -----------------------------------------------------------------
! This file tests the Fortran 2003 interface to the SUNDIALS
! band SUNMatrix implementation.
! -----------------------------------------------------------------

module test_fsunmatrix_band
  use, intrinsic :: iso_c_binding
  implicit none

  integer(C_LONG), parameter :: N  = 4
  integer(C_LONG), parameter :: mu = 1
  integer(C_LONG), parameter :: ml = 1

contains

  integer(C_INT) function smoke_tests() result(fails)

    !======== Inclusions ==========
    use, intrinsic :: iso_c_binding
    use fsundials_nvector_mod
    use fsundials_matrix_mod
    use fsunmatrix_band_mod
    use fnvector_serial_mod
    use test_utilities

    !======== Declarations ========
    implicit none

    ! local variables
    type(SUNMatrix), pointer :: A, B               ! SUNMatrix
    type(N_Vector),  pointer :: x, y               ! NVectors
    real(C_DOUBLE),  pointer :: matdat(:)          ! matrix data pointer
    integer(C_LONG)          :: lenrw(1), leniw(1) ! matrix real and int work space size
    integer(C_LONG)          :: val
    type(C_PTR),     pointer :: cptr

    fails = 0
    x => FN_VNew_Serial(N)
    y => FN_VNew_Serial(N)

    !===== Calls to interface =====

    ! constructor
    A => FSUNBandMatrix(N, mu, ml)
    if (.not. associated(A)) then
      print *,'>>> FAILED - ERROR in FSUNBandMatrix; halting'
      fails = 1
      return
    end if

    ! misc. matrix functions
    val = FSUNMatGetID_Band(A)
    val = FSUNBandMatrix_Rows(A)
    val = FSUNBandMatrix_Columns(A)
    val = FSUNBandMatrix_LowerBandwidth(A)
    val = FSUNBandMatrix_UpperBandwidth(A)
    val = FSUNBandMatrix_StoredUpperBandwidth(A)
    val = FSUNBandMatrix_LDim(A)
    matdat => FSUNBandMatrix_Data(A)
    cptr   => FSUNBandMatrix_Cols(A)
    matdat => FSUNBandMatrix_Column(A, N)

    ! matrix operations
    B => FSUNMatClone_Band(A)
    if (.not. associated(B)) then
      print *,'>>> FAILED - ERROR in FSUNMatClone_Band; halting'
      fails = 1
      return
    end if
    fails = fails + FSUNMatZero_Band(A)
    fails = fails + FSUNMatCopy_Band(A,B)
    fails = fails + FSUNMatScaleAdd_Band(ONE, A, B)
    fails = fails + FSUNMatScaleAddI_Band(ONE, A)
    fails = fails + FSUNMatMatvec_Band(A, x, y)
    fails = fails + FSUNMatSpace_Band(A, lenrw, leniw)

    !======= Cleanup ===========
    call FSUNMatDestroy_Band(A)
    call FSUNMatDestroy_Band(B)
    call FN_VDestroy_Serial(x)
    call FN_VDestroy_Serial(y)

  end function smoke_tests

  integer(C_INT) function unit_tests() result(fails)
    use, intrinsic :: iso_c_binding
    use fsundials_nvector_mod
    use fsundials_matrix_mod
    use fnvector_serial_mod
    use fsunmatrix_band_mod
    use test_sunmatrix

    implicit none

    type(SUNMatrix), pointer :: A, I
    type(N_Vector),  pointer :: x, y
    real(C_DOUBLE),  pointer :: Adata(:), Idata(:), colj(:), xdata(:), ydata(:)
    integer(C_LONG)          :: ii, jj, smu, jstart, jend, offset

    fails = 0

    A => FSUNBandMatrix(N, mu, ml)
    I => FSUNBandMatrix(N, 0_8, 0_8)
    x => FN_VNew_Serial(N)
    y => FN_VNew_Serial(N)

    ! Fill identity matrix
    Idata => FSUNBandMatrix_Data(I)
    do jj = 0, N-1
      colj => FSUNBandMatrix_Column(I, jj)
      colj(1) = ONE
    end do

    ! Fill A matrix
    smu   = FSUNBandMatrix_StoredUpperBandwidth(A)
    Adata => FSUNBandMatrix_Data(A)
    do jj = 0, N-1
      offset = smu-mu+1 + jj*(smu+ml+1)
      colj(-mu:ml) => Adata(offset:mu+ml)
      jstart = merge(-jj, -mu, jj < mu)
      jend = merge(N-1-jj, ml, jj > N-1-ml)
      do ii = jstart, jend
        colj(ii) = jj - ii
      end do
    end do

    xdata(0:N-1) => FN_VGetArrayPointer(x)
    ydata(0:N-1) => FN_VGetArrayPointer(y)

    ! Fill vectors
    do ii = 0, N-1

      ! x vector
      xdata(ii) = ii

      ! y vector
      ydata(ii) = ZERO
      jstart    = max(0, ii-ml)
      jend      = min(N-1, ii+mu)
      do jj = jstart, jend
        ydata(ii) = ydata(ii) + (jj+jj-ii)*(jj)
      end do
    end do

    fails = fails + Test_FSUNMatGetID(A, SUNMATRIX_BAND, 0)
    fails = fails + Test_FSUNMatClone(A, 0)
    fails = fails + Test_FSUNMatCopy(A, 0)
    fails = fails + Test_FSUNMatZero(A, 0)
    fails = fails + Test_FSUNMatScaleAdd(A, I, 0)
    fails = fails + Test_FSUNMatScaleAddI(A, I, 0)
    fails = fails + Test_FSUNMatMatvec(A, x, y, 0)
    fails = fails + Test_FSUNMatSpace(A, 0)

    ! cleanup
    call FSUNMatDestroy(A)
    call FSUNMatDestroy(I)
    call FN_VDestroy(x)
    call FN_VDestroy(y)

  end function unit_tests

end module

program main
  !======== Inclusions ==========
  use, intrinsic :: iso_c_binding
  use test_fsunmatrix_band

  !======== Declarations ========
  implicit none
  integer(C_INT) :: fails = 0

  !============== Introduction =============
  print *, 'Band SUNMatrix Fortran 2003 interface test'

  fails = unit_tests()
  if (fails /= 0) then
    print *, 'FAILURE: n unit tests failed'
    stop 1
  else
    print *, 'SUCCESS: all unit tests passed'
  end if

end program main

! exported functions used by test_sunmatrix
integer(C_INT) function check_matrix(B, A, tol) result(fails)
  use, intrinsic :: iso_c_binding
  use fsundials_matrix_mod
  use fsunmatrix_band_mod
  use test_utilities

  implicit none

  type(SUNMatrix) :: A, B
  real(C_DOUBLE)  :: tol
  real(C_DOUBLE), pointer :: Adata(:), Bdata(:), Acolj(:), Bcolj(:)
  integer(C_LONG) :: N, smu, mu, ml, ii, istart, iend, jj, offset

  fails = 0

  N   = FSUNBandMatrix_Columns(A)
  smu = FSUNBandMatrix_StoredUpperBandwidth(A)
  mu  = FSUNBandMatrix_UpperBandwidth(A)
  ml  = FSUNBandMatrix_LowerBandwidth(A)

  if (FSUNMatGetID(A) /= FSUNMatGetID(B)) then
    fails = 1
    return
  end if

  if (FSUNBandMatrix_Columns(A) /= FSUNBandMatrix_Columns(B)) then
    fails = 1
    return
  end if

  if (FSUNBandMatrix_Rows(A) /= FSUNBandMatrix_Rows(B)) then
    fails = 1
    return
  end if

  if (FSUNBandMatrix_LowerBandwidth(A) /= FSUNBandMatrix_LowerBandwidth(B)) then
    fails = 1
    return
  end if

  if (FSUNBandMatrix_UpperBandwidth(A) /= FSUNBandMatrix_UpperBandwidth(B)) then
    fails = 1
    return
  end if

  if (FSUNBandMatrix_StoredUpperBandwidth(A) /= FSUNBandMatrix_StoredUpperBandwidth(B)) then
    fails = 1
    return
  end if

  Adata => FSUNBandMatrix_Data(A)
  Bdata => FSUNBandMatrix_Data(B)
  do jj = 0, N-1
    offset = smu-mu+1 + jj*(smu+ml+1)
    Acolj(-mu:ml) => Adata(offset:mu+ml)
    Bcolj(-mu:ml) => Bdata(offset:mu+ml)
    istart = merge(-jj, -mu, jj < mu)
    iend = merge(N-1-jj, ml, jj > N-1-ml)
    do ii = istart, iend
      fails = fails + FNEQTOL(Acolj(ii), Bcolj(ii), tol)
    end do
  end do

end function check_matrix

integer(C_INT) function check_matrix_entry(A, c, tol) result(fails)
  use, intrinsic :: iso_c_binding
  use fsundials_matrix_mod
  use fsunmatrix_band_mod
  use test_utilities

  implicit none

  type(SUNMatrix) :: A
  real(C_DOUBLE)  :: c, tol
  real(C_DOUBLE), pointer :: Adata(:), colj(:)
  integer(C_LONG) :: N, smu, mu, ml, ii, istart, iend, jj, offset

  fails = 0

  N   = FSUNBandMatrix_Columns(A)
  smu = FSUNBandMatrix_StoredUpperBandwidth(A)
  mu  = FSUNBandMatrix_UpperBandwidth(A)
  ml  = FSUNBandMatrix_LowerBandwidth(A)
  Adata => FSUNBandMatrix_Data(A)

  do jj = 0, N-1
    offset = smu-mu+1 + jj*(smu+ml+1)
    colj(-mu:ml) => Adata(offset:mu+ml)
    istart = merge(-jj, -mu, jj < mu)
    iend   = merge(N-1-jj, ml, jj > N-1-ml)
    do ii = istart, iend
      if (FNEQTOL(colj(ii), c, tol) /= 0) then
        fails = fails + 1
        write(*,'(A,E10.1,A,E14.7,A,I9,A,E14.7)') "tol = ", tol,  &
              "   c = ", c, "   data[", ii, "] = ", colj(ii)
      end if
    end do
  end do

end function check_matrix_entry

logical function is_square(A) result(res)
  use fsundials_matrix_mod
  use fsunmatrix_band_mod

  implicit none

  type(SUNMatrix) :: A

  if (FSUNBandMatrix_Rows(A) == FSUNBandMatrix_Columns(A)) then
    res = .true.
  else
    res = .false.
  end if

end function is_square


      SUBROUTINE genmn(parm,x,work)
C**********************************************************************
C
C     SUBROUTINE GENMN(PARM,X,WORK)
C              GENerate Multivariate Normal random deviate
C
C
C                              Arguments
C
C
C     PARM --> Parameters needed to generate multivariate normal
C               deviates (MEANV and Cholesky decomposition of
C               COVM). Set by a previous call to SETGMN.
C               1 : 1                - size of deviate, P
C               2 : P + 1            - mean vector
C               P+2 : P*(P+3)/2 + 1  - upper half of cholesky
C                                       decomposition of cov matrix
C                                             REAL PARM(*)
C
C     X    <-- Vector deviate generated.
C                                             REAL X(P)
C
C     WORK <--> Scratch array
C                                             REAL WORK(P)
C
C
C                              Method
C
C
C     1) Generate P independent standard normal deviates - Ei ~ N(0,1)
C
C     2) Using Cholesky decomposition find A s.t. trans(A)*A = COVM
C
C     3) trans(A)E + MEANV ~ N(MEANV,COVM)
C
C**********************************************************************
C     .. Array Arguments ..
      REAL parm(*),work(*),x(*)
C     ..
C     .. Local Scalars ..
      REAL ae
      INTEGER i,icount,j,p
C     ..
C     .. External Functions ..
      REAL snorm
      EXTERNAL snorm
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC int
C     ..
C     .. Executable Statements ..
      p = int(parm(1))
C
C     Generate P independent normal deviates - WORK ~ N(0,1)
C
      DO 10,i = 1,p
          work(i) = snorm()
   10 CONTINUE
      DO 30,i = 1,p
C
C     PARM (P+2 : P*(P+3)/2 + 1) contains A, the Cholesky
C      decomposition of the desired covariance matrix.
C          trans(A)(1,1) = PARM(P+2)
C          trans(A)(2,1) = PARM(P+3)
C          trans(A)(2,2) = PARM(P+2+P)
C          trans(A)(3,1) = PARM(P+4)
C          trans(A)(3,2) = PARM(P+3+P)
C          trans(A)(3,3) = PARM(P+2-1+2P)  ...
C
C     trans(A)*WORK + MEANV ~ N(MEANV,COVM)
C
          icount = 0
          ae = 0.0
          DO 20,j = 1,i
              icount = icount + j - 1
              ae = ae + parm(i+ (j-1)*p-icount+p+1)*work(j)
   20     CONTINUE
          x(i) = ae + parm(i+1)
   30 CONTINUE
      RETURN
C
      END


      SUBROUTINE SHXTRS (NROW,NCOL,ARRAY)
C
C     TO EXTRAPOLATE VALUES IN ARRAY FROM A SET OF EVALUATION POINTS TO
C     THE GRID POINTS OF SPECIFIC SHELL ELEMENTS.
C     THE EXTRAPOLATION IS IN TWO DIMENSIONS.
C
C     INPUT :
C           NROW   - SIZE OF THE SET OF VALUES
C           NCOL   - NUMBER OF EVALUATION POINTS
C           ARRAY  - ARRAY OF DATA TO BE EXTRAPOLATED
C
C     OUTPUT:
C           ARRAY  - ARRAY OF EXTRAPOLATED DATA
C
C
      LOGICAL TRIA
      REAL    ARRAY(NROW,1),TEMP(4,4),SHP(4),TPOINT(2,3),QPOINT(2,4),
     1        XSI,ETA
C
C
C
      DATA    TPOINT  / 0.0,  0.0,  1.0,  0.0,  0.0,  1.0             /
      DATA    QPOINT  /-1.0, -1.0,  1.0, -1.0,  1.0,  1.0, -1.0,  1.0 /
C
C     INITIALIZE
C
      TRIA   = NCOL .EQ. 3
C
      DO 10 I = 1,NROW
      DO 10 J = 1,NCOL
      TEMP(I,J) = 0.0
   10 CONTINUE
C
C     BEGIN LOOP ON DESTINATION POINTS
C
      DO 70 I = 1,NCOL
C
C     EVALUATE PSEUDO-SHAPE FUNCTIONS
C
      IF (.NOT.TRIA) GO TO 30
C
      XSI    = TPOINT(1,I)
      ETA    = TPOINT(2,I)
      SHP(1) = 1.66666667 - 2.0*XSI - 2.0*ETA
      SHP(2) = 2.0*XSI - 0.33333333
      SHP(3) = 2.0*ETA - 0.33333333
      GO TO 40
C
   30 XSI    = QPOINT(1,I)
      ETA    = QPOINT(2,I)
      CONST  = 0.577350269
      SHP(1) = 0.75*(CONST-XSI)*(CONST-ETA)
      SHP(2) = 0.75*(CONST-XSI)*(CONST+ETA)
      SHP(3) = 0.75*(CONST+XSI)*(CONST-ETA)
      SHP(4) = 0.75*(CONST+XSI)*(CONST+ETA)
C
C     EXTRAPOLATE
C
   40 DO 50 J = 1,NROW
      DO 50 K = 1,NCOL
      TEMP(J,I) = TEMP(J,I) + SHP(K)*ARRAY(J,K)
   50 CONTINUE
C
   70 CONTINUE
C
C     COPY THE EXTRAPOLATED DATA BACK INTO ARRAY
C
      DO 90 J = 1,NCOL
      DO 90 I = 1,NROW
      ARRAY(I,J) = TEMP(I,J)
   90 CONTINUE
C
      RETURN
      END


*     SB01DD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX
      PARAMETER        ( NMAX = 20, MMAX = 20 )
      INTEGER          LDA, LDB, LDG, LDZ
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDG = MMAX,
     $                   LDZ = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( 3*NMAX, MMAX*NMAX,
     $                                 MMAX*MMAX + 2*NMAX + 4*MMAX + 1 )
     $                 )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          COUNT, I, INDCON, INFO1, INFO2, J, M, N, NCONT
      CHARACTER*1      JOBZ
*     .. Local Arrays ..
      INTEGER          IWORK(MMAX), NBLK(NMAX)
      DOUBLE PRECISION A(LDA,NMAX), B(NMAX,MMAX), DWORK(LDWORK),
     $                 G(LDG,NMAX), WI(NMAX), WR(NMAX), Y(MMAX*NMAX),
     $                 Z(LDZ,NMAX)
*     .. External Subroutines ..
      EXTERNAL         AB01ND, SB01DD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, TOL, JOBZ
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99993 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            READ ( NIN, FMT = * ) ( WR(I), I = 1,N )
            READ ( NIN, FMT = * ) ( WI(I), I = 1,N )
            READ ( NIN, FMT = * ) ( Y(I),  I = 1,M*N )
*           First reduce the given system to canonical form.
            CALL AB01ND( JOBZ, N, M, A, LDA, B, LDB, NCONT, INDCON,
     $                   NBLK, Z, LDZ, DWORK, TOL, IWORK, DWORK(N+1),
     $                   LDWORK-N, INFO1 )
*
            IF ( INFO1.EQ.0 ) THEN
*              Find the state feedback matrix G.
               CALL SB01DD( N, M, INDCON, A, LDA, B, LDB, NBLK, WR, WI,
     $                      Z, LDZ, Y, COUNT, G, LDG, TOL, IWORK, DWORK,
     $                      LDWORK, INFO2 )
*
               IF ( INFO2.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99997 ) INFO2
               ELSE
                  WRITE ( NOUT, FMT = 99996 )
                  DO 10 I = 1, M
                     WRITE ( NOUT, FMT = 99995 ) ( G(I,J), J = 1,N )
   10             CONTINUE
               END IF
            ELSE
               WRITE ( NOUT, FMT = 99998 ) INFO1
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB01DD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB01ND =',I2)
99997 FORMAT (' INFO on exit from SB01DD =',I2)
99996 FORMAT (' The state feedback matrix G is')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (/' N is out of range.',/' N = ',I5)
99993 FORMAT (/' M is out of range.',/' M = ',I5)
      END


      SUBROUTINE RZDCAL(AMAT,IH,IK,IL,R0,Z0,D0)
      IMPLICIT NONE
C
      REAL AMAT(3,3)
      REAL R0,Z0,D0
      INTEGER IH,IK,IL
C
      INTEGER I,J
      REAL RC(3),H(3)
C
      H(1) = FLOAT(IH)
      H(2) = FLOAT(IK)
      H(3) = FLOAT(IL)
C
      D0 = 0.0
      DO 20 I=1,3
         RC(I) = 0.0
         DO 10 J=1,3
            RC(I) = RC(I) + AMAT(I,J)*H(J)
 10      CONTINUE
         D0 = D0 + RC(I)**2
 20   CONTINUE
      Z0 = ABS(RC(3))
      IF(D0.GT.Z0*Z0)THEN
         R0 = SQRT(D0-Z0*Z0)
      ELSE
         R0 = 0.0
      ENDIF
      D0 = SQRT(D0)
      RETURN
C
      END


!***********************************************************************
!                                                                      *
      REAL(KIND(0.0D0)) FUNCTION VINTI (J, K)
!                                                                      *
!   The value of this  function is the one-electron integral V (J,K)   *
!   for  orbitals  J, K. The analytical expression for this quantity   *
!   is given as  eq (3.23) in  F A  Parpia, M. Tong and C F Fischer,   *
!   to appear.                                                         *
!                                                                      *
!   Call(s) to: [LIB92]: DPBDT, QUAD.                                  *
!                                                                      *
!   Written by M Tong and F A Parpia,     Last revision: 15 Oct 1992   *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:04:58   1/ 3/07
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE debug_C
      USE grid_C
      USE orb_C
      USE tatb_C
      USE wave_C
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE dpbdt_I
      USE quad_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: J
      INTEGER  :: K
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: I, KPJ, KPK, IFACT1, IFACT2
      REAL(DOUBLE) :: PIECE1, FACT1, FACT2, PIECE2
!-----------------------------------------------
!
      MTP = MAX(MF(J),MF(K))
!
!   Piece involving derivatives
!
      CALL DPBDT (K)
      TA(1) = 0.0D00
      DO I = 2, MTP
         TA(I) = PF(I,J)*TA(I) + QF(I,J)*TB(I)
      END DO
      CALL QUAD (PIECE1)
      PIECE1 = PIECE1/H
!
!   Pieces not involving derivatives
!
      KPJ = NAK(J)
      KPK = NAK(K)
      IFACT1 = KPJ*(KPJ + 1) - KPK*(KPK + 1)
      FACT1 = 0.5D00*DBLE(IFACT1)
      IFACT2 = (-KPJ*((-KPJ) + 1)) + KPK*((-KPK) + 1)
      FACT2 = 0.5D00*DBLE(IFACT2)
      TA(1) = 0.0D00
      DO I = 2, MTP
         TA(I) = RPOR(I)*(FACT1*PF(I,J)*PF(I,K) + FACT2*QF(I,J)*QF(I,K))
      END DO
      CALL QUAD (PIECE2)
!
      VINTI = PIECE1 - PIECE2
!
!   Debug printout
!
      IF (LDBPR(6)) WRITE (99, 300) NP(J), NH(J), NP(K), NH(K), VINTI
!
      RETURN
!
  300 FORMAT(/,'VINTI: V (',1I2,1A2,',',1I2,1A2,') = ',1P,D19.12)
      RETURN
!
      END FUNCTION VINTI