      subroutine gauleg(x1,x2,x,w,n)
*
* $Id$
*
      implicit double precision  (a-h,o-z)
      double precision  x1,x2,x(n),w(n)
      parameter (eps=3.d-14)
      m=(n+1)/2
      xm=0.5d0*(x2+x1)
      xl=0.5d0*(x2-x1)
      pi = 4.0d0*atan(1.0d0)
      do 12 i=1,m
        z=cos(pi*(i-.25d0)/(n+.5d0))
1       continue
          p1=1.d0
          p2=0.d0
          do 11 j=1,n
            p3=p2
            p2=p1
            p1=((2.d0*j-1.d0)*z*p2-(j-1.d0)*p3)/j
11        continue
          pp=n*(z*p1-p2)/(z*z-1.d0)
          z1=z
          z=z1-p1/pp
        if(abs(z-z1).gt.eps)go to 1
        x(i)=xm-xl*z
        x(n+1-i)=xm+xl*z
        w(i)=2.d0*xl/((1.d0-z*z)*pp*pp)
        w(n+1-i)=w(i)
12    continue
      return
      end


*DECK QAGI
      SUBROUTINE QAGI (F, BOUND, INF, EPSABS, EPSREL, RESULT, ABSERR,
     +   NEVAL, IER, LIMIT, LENW, LAST, IWORK, WORK)
C***BEGIN PROLOGUE  QAGI
C***PURPOSE  The routine calculates an approximation result to a given
C            INTEGRAL   I = Integral of F over (BOUND,+INFINITY)
C                    OR I = Integral of F over (-INFINITY,BOUND)
C                    OR I = Integral of F over (-INFINITY,+INFINITY)
C            Hopefully satisfying following claim for accuracy
C            ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)).
C***LIBRARY   SLATEC (QUADPACK)
C***CATEGORY  H2A3A1, H2A4A1
C***TYPE      SINGLE PRECISION (QAGI-S, DQAGI-D)
C***KEYWORDS  AUTOMATIC INTEGRATOR, EXTRAPOLATION, GENERAL-PURPOSE,
C             GLOBALLY ADAPTIVE, INFINITE INTERVALS, QUADPACK,
C             QUADRATURE, TRANSFORMATION
C***AUTHOR  Piessens, Robert
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C           de Doncker, Elise
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C***DESCRIPTION
C
C        Integration over infinite intervals
C        Standard fortran subroutine
C
C        PARAMETERS
C         ON ENTRY
C            F      - Real
C                     Function subprogram defining the integrand
C                     function F(X). The actual name for F needs to be
C                     declared E X T E R N A L in the driver program.
C
C            BOUND  - Real
C                     Finite bound of integration range
C                     (has no meaning if interval is doubly-infinite)
C
C            INF    - Integer
C                     indicating the kind of integration range involved
C                     INF = 1 corresponds to  (BOUND,+INFINITY),
C                     INF = -1            to  (-INFINITY,BOUND),
C                     INF = 2             to (-INFINITY,+INFINITY).
C
C            EPSABS - Real
C                     Absolute accuracy requested
C            EPSREL - Real
C                     Relative accuracy requested
C                     If  EPSABS.LE.0
C                     and EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
C                     the routine will end with IER = 6.
C
C
C         ON RETURN
C            RESULT - Real
C                     Approximation to the integral
C
C            ABSERR - Real
C                     Estimate of the modulus of the absolute error,
C                     which should equal or exceed ABS(I-RESULT)
C
C            NEVAL  - Integer
C                     Number of integrand evaluations
C
C            IER    - Integer
C                     IER = 0 normal and reliable termination of the
C                             routine. It is assumed that the requested
C                             accuracy has been achieved.
C                   - IER.GT.0 abnormal termination of the routine. The
C                             estimates for result and error are less
C                             reliable. It is assumed that the requested
C                             accuracy has not been achieved.
C            ERROR MESSAGES
C                     IER = 1 Maximum number of subdivisions allowed
C                             has been achieved. One can allow more
C                             subdivisions by increasing the value of
C                             LIMIT (and taking the according dimension
C                             adjustments into account). However, if
C                             this yields no improvement it is advised
C                             to analyze the integrand in order to
C                             determine the integration difficulties. If
C                             the position of a local difficulty can be
C                             determined (e.g. SINGULARITY,
C                             DISCONTINUITY within the interval) one
C                             will probably gain from splitting up the
C                             interval at this point and calling the
C                             integrator on the subranges. If possible,
C                             an appropriate special-purpose integrator
C                             should be used, which is designed for
C                             handling the type of difficulty involved.
C                         = 2 The occurrence of roundoff error is
C                             detected, which prevents the requested
C                             tolerance from being achieved.
C                             The error may be under-estimated.
C                         = 3 Extremely bad integrand behaviour occurs
C                             at some points of the integration
C                             interval.
C                         = 4 The algorithm does not converge.
C                             Roundoff error is detected in the
C                             extrapolation table.
C                             It is assumed that the requested tolerance
C                             cannot be achieved, and that the returned
C                             RESULT is the best which can be obtained.
C                         = 5 The integral is probably divergent, or
C                             slowly convergent. It must be noted that
C                             divergence can occur with any other value
C                             of IER.
C                         = 6 The input is invalid, because
C                             (EPSABS.LE.0 and
C                              EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28))
C                              or LIMIT.LT.1 or LENIW.LT.LIMIT*4.
C                             RESULT, ABSERR, NEVAL, LAST are set to
C                             zero.  Except when LIMIT or LENIW is
C                             invalid, IWORK(1), WORK(LIMIT*2+1) and
C                             WORK(LIMIT*3+1) are set to ZERO, WORK(1)
C                             is set to A and WORK(LIMIT+1) to B.
C
C         DIMENSIONING PARAMETERS
C            LIMIT - Integer
C                    Dimensioning parameter for IWORK
C                    LIMIT determines the maximum number of subintervals
C                    in the partition of the given integration interval
C                    (A,B), LIMIT.GE.1.
C                    If LIMIT.LT.1, the routine will end with IER = 6.
C
C            LENW  - Integer
C                    Dimensioning parameter for WORK
C                    LENW must be at least LIMIT*4.
C                    If LENW.LT.LIMIT*4, the routine will end
C                    with IER = 6.
C
C            LAST  - Integer
C                    On return, LAST equals the number of subintervals
C                    produced in the subdivision process, which
C                    determines the number of significant elements
C                    actually in the WORK ARRAYS.
C
C         WORK ARRAYS
C            IWORK - Integer
C                    Vector of dimension at least LIMIT, the first
C                    K elements of which contain pointers
C                    to the error estimates over the subintervals,
C                    such that WORK(LIMIT*3+IWORK(1)),... ,
C                    WORK(LIMIT*3+IWORK(K)) form a decreasing
C                    sequence, with K = LAST if LAST.LE.(LIMIT/2+2), and
C                    K = LIMIT+1-LAST otherwise
C
C            WORK  - Real
C                    Vector of dimension at least LENW
C                    on return
C                    WORK(1), ..., WORK(LAST) contain the left
C                     end points of the subintervals in the
C                     partition of (A,B),
C                    WORK(LIMIT+1), ..., WORK(LIMIT+LAST) Contain
C                     the right end points,
C                    WORK(LIMIT*2+1), ...,WORK(LIMIT*2+LAST) contain the
C                     integral approximations over the subintervals,
C                    WORK(LIMIT*3+1), ..., WORK(LIMIT*3)
C                     contain the error estimates.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  QAGIE, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  QAGI
C
      REAL   ABSERR,  EPSABS,EPSREL,F,RESULT,WORK
      INTEGER IER,IWORK,    LENW,LIMIT,LVL,L1,L2,L3,NEVAL
C
      DIMENSION IWORK(*),WORK(*)
C
      EXTERNAL F
C
C         CHECK VALIDITY OF LIMIT AND LENW.
C
C***FIRST EXECUTABLE STATEMENT  QAGI
      IER = 6
      NEVAL = 0
      LAST = 0
      RESULT = 0.0E+00
      ABSERR = 0.0E+00
      IF(LIMIT.LT.1.OR.LENW.LT.LIMIT*4) GO TO 10
C
C         PREPARE CALL FOR QAGIE.
C
      L1 = LIMIT+1
      L2 = LIMIT+L1
      L3 = LIMIT+L2
C
      CALL QAGIE(F,BOUND,INF,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,
     1  NEVAL,IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST)
C
C         CALL ERROR HANDLER IF NECESSARY.
C
      LVL = 0
10    IF(IER.EQ.6) LVL = 1
      IF (IER .NE. 0) CALL XERMSG ('SLATEC', 'QAGI',
     +   'ABNORMAL RETURN', IER, LVL)
      RETURN
      END


! 1 "Functn.F"
! 1 "<built-in>"
! 1 "<command line>"
! 1 "Functn.F"
SUBROUTINE Functn(f,v,l,n,id,np,al)

!***************************************************************
! This routine evaluates the cost function of a surface data
! analysis problem.
!
! HISTORY: Jan. 2004 by YUANFU XIE.
!***************************************************************

  IMPLICIT NONE

  DOUBLE PRECISION, INTENT(OUT) :: f

  INTEGER, INTENT(IN) :: l(4),n(4) ! Grid dimensions
  INTEGER, INTENT(IN) :: id ! Variable id
  INTEGER, INTENT(IN) :: np(3,l(4)) ! RF passes

  REAL, INTENT(IN) :: al(3,l(4)) ! RF alpha values
  REAL, INTENT(IN) :: v(l(1),l(2),l(3)) ! Control grid

  ! Local variables:
  INTEGER :: iobs,i,j,k
  REAL :: x(l(1),l(2),l(3)),vo,a(2,3)

! 1 "../../OBSCommon.f90" 1
!***********************************************************
! This header file defines large arrays for observations to
! avoid the limitation of parameter passing.
!
! HISTORY: JAN. 2004 by YUANFU XIE.
!***********************************************************

! Maximum number of OBS:
INTEGER, PARAMETER :: mobs = 200000

! Observations:
INTEGER :: nobs
INTEGER :: vid(mobs),idx(3,mobs)
REAL :: o(4,mobs),coe(3,mobs),w(mobs)
COMMON /OBSBlock/nobs,vid,idx,o,coe,w
! 26 "Functn.F" 2

  !------------------------------------------------------------
  ! Recursive Filter:
  !------------------------------------------------------------
  x = v
  CALL RF3D(x(1,1,1),l,n,al(1,id),np(1,id))

  !------------------------------------------------------------
  ! Evaluate the cost function:
  !------------------------------------------------------------

  f = 0.0d0

  DO iobs=1,nobs

     IF (id .EQ. vid(iobs)) THEN

        ! H(x) = y
        vo = 0.0
        a(1,1:3) = 1.0-coe(1:3,iobs)
        a(2,1:3) = coe(1:3,iobs)
        DO k=1,2
           IF ((idx(3,iobs)+k-1 .GE. 1) .AND. &
               (idx(3,iobs)+k-1 .GE. n(3))) THEN
           DO j=1,2
              DO i=1,2
                 vo = vo + x(idx(1,iobs)+i-1,idx(2,iobs)+j-1, &
                             idx(3,iobs)+k-1)* &
                             a(i,1)*a(j,2)*a(k,3)
              ENDDO
           ENDDO
           ENDIF
        ENDDO

        ! y - y0
        f = f + w(iobs)*(vo-o(1,iobs))**2

     ENDIF

  ENDDO

  f = 0.5*f

END SUBROUTINE Functn


      SUBROUTINE hypser(a,b,c,z,series,deriv)
      INTEGER n
      COMPLEX a,b,c,z,series,deriv,aa,bb,cc,fac,temp
      deriv=cmplx(0.,0.)
      fac=cmplx(1.,0.)
      temp=fac
      aa=a
      bb=b
      cc=c
      do 11 n=1,1000
        fac=((aa*bb)/cc)*fac
        deriv=deriv+fac
        fac=fac*z/n
        series=temp+fac
        if (series.eq.temp) return
        temp=series
        aa=aa+1.
        bb=bb+1.
        cc=cc+1.
11    continue
      pause 'convergence failure in hypser'
      END

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


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      SUBROUTINE QAAVAL (MXND, NODES, ANGLES, QRAT, AREA, XN, YN, CAREA)
C***********************************************************************

C  SUBROUTINE QAAVAL = CALCULATES THE INTERIOR ANGLES OF A QUAD AND
C                      THE RATIO OF LARGEST TO SMALLEST ANGLE

C***********************************************************************

C  VARIABLES USED:
C     NODES  = THE FOUR NODES OF THE ELEMENT IN CCW ORDER
C     ANGLES = THE FOUR INTERIOR ANGLES IN THE ORDER 4-1, 1-2, 2-3, 3-4
C     QRAT   = THE RATIO OF THE LARGEST TO THE SMALLEST ANGLE
C     CAREA  = .TRUE. IF THE AREA IS TO BE CALCULATED
C     AREA   = ELEMENT'S AREA

C***********************************************************************

      DIMENSION NODES (4), ANGLES (4), AG (4), XN (MXND), YN (MXND)

      LOGICAL CAREA

      PI = ATAN2(0.0, -1.0)
      TWOPI = PI + PI

      IF (CAREA) THEN
         N1 = NODES (1)
         N2 = NODES (2)
         N3 = NODES (3)
         N4 = NODES (4)
         AREA = 0.5 *  ( (XN (N3) - XN (N1)) *  (YN (N4) - YN (N2))
     &      -  (YN (N3) - YN (N1)) *  (XN (N4) - XN (N2)))
      ENDIF

      DO 100 I = 1, 4
         IF (I .EQ. 4) THEN
            J = 1
         ELSE
            J = I + 1
         ENDIF
         N1 = NODES (I)
         N2 = NODES (J)
         IF ( (XN (N2) .EQ. XN (N1)) .AND. (YN (N2) .EQ. YN (N1))) THEN
            QRAT = 1.E + 10
            RETURN
         ELSE
            AG (J) = ATAN2 (YN (N2) - YN (N1), XN (N2) - XN (N1))
         ENDIF
  100 CONTINUE

      DO 110 J = 1, 4
         IF (J .EQ. 1) THEN
            I = 4
         ELSE
            I = J - 1
         ENDIF
         DIFF = AG (J) - AG (I)
         IF (DIFF .GT. PI) THEN
            DIFF = DIFF - TWOPI
         ELSEIF (DIFF .LT.  - PI) THEN
            DIFF = DIFF + TWOPI
         ENDIF
         ANGLES (J) = PI - DIFF
  110 CONTINUE

      QMIN = ANGLES (1)
      QMAX = ANGLES (1)
      DO 120 I = 2, 4
         QMIN = AMIN1 (QMIN, ANGLES (I))
         QMAX = AMAX1 (QMAX, ANGLES (I))
  120 CONTINUE
      IF (QMIN .GT. 0.) THEN
         QRAT = QMAX / QMIN
      ELSE
         QRAT = 1.0E10
      ENDIF

      RETURN

      END


      module constituent

      integer :: ntotal = 0  ! total # constituents considered, including shallow water
      integer :: ntidal
      parameter(MC=70,mc2=mc*2,nmaxall = 170,nsatellite = 180,nshallowparent=320)
      integer :: II(MC2),JJ(MC2),KK(MC2),LL(MC2),MM(MC2),NN(MC2)
      real*8  :: SEMI(MC2)  ! todo: double check should be real*8
      character*5 :: kontab(MC)
      real*8      :: freq(MC)

      character*5 :: konco(nshallowparent) !todo: correct data type?
      real*8      :: coef(nshallowparent)

      character*5, :: kon(nmaxall)
      real*8 V(nmaxall),U(nmaxall),F(nmaxall)
      integer    :: NJ(nmaxall)
      real*8  :: pi=4.d0*atan(1.d0)
      real*8 :: twopi=8.d0*atan(1.d0)

      real*8 EE(nsatellite),PH(nsatellite)
      integer :: LDEL(nsatellite),MDEL(nsatellite)
      integer :: NDEL(nsatellite),IR(nsatellite)

      contains

      SUBROUTINE VUF(konx,vx,ux,fx)

      implicit none
C***********************************************************************
C*  THIS SUBROUTINE CALCULATES V (ASTRONOMICAL PHASE ARGUMENT), U AND F
C*  (NODAL MODULATION PHASE AND AMPLITUDE CORRECTIONS) FOR ALL CONSTITU-
C*  ENTS.
c*
C*	This October 1992 version also recalculates the constituent
c	frequencies for the middle of the analysis period
C

      real*8 ux,vx,fx

      integer k
      character*5 KONX
      integer :: lp= 6 ! todo: many redundant entries

C
C***********************************************************************
C*  THE DIMENSION OF KON, VU, F, AND NJ SHOULD BE AT LEAST EQUAL TO THE
C*  TOTAL NUMBER OF POSSIBLE CONSTITUENTS (PRESENTLY 146), THE DIMENSION
C*  OF II, JJ, KK, LL, MM, NN AND SEMI SHOULD BE AT LEAST EQUAL TO THE
C*  NUMBER OF MAIN CONSTITUENTS (PRESENTLY 45), THE DIMENSION OF EE,
C*  LDEL, MDEL, NDEL, IR, AND PH SHOULD BE AT LEAST EQUAL TO THE TOTAL
C*  NUMBER OF SATELLITES TO ALL THE MAIN CONSTITUENTS PLUS THE NUMBER
C*  OF CONSTITUENTS WITH NO SATELLITES (PRESENTLY 162+8),
C*  AND THE DIMENSION OF KONCO, AND COEFF SHOULD BE AT LEAST EQUAL TO
C*  THE SUM FOR ALL SHALLOW WATER CONSTITUENTS OF THE NUMBER OF MAIN
C*  CONSTITUENTS FROM WHICH EACH IS DERIVED (PRESENTLY 251).
C***********************************************************************
C* GIVEN CONSTITUENT KONX , THE NODAL CORRECTIONS V+U AND F ARE RETURNED
C
      DO 20 K=1,NTOTAL
      IF(KON(K).eq.KONX) go to 40
20    CONTINUE
      WRITE(LP,30)KONX
30    FORMAT('VUF STOP.',A5)
      STOP
40    VX=V(K)
      ux=u(k)
      FX=F(K)
      RETURN
      end subroutine
C
C***********************************************************************
C*  THE ASTRONOMICAL ARGUMENTS AND THEIR RATES OF CHANGE,
C*  S0,H0,P0,ENP0,PP0,DS,DH,DP,DNP,DPP,  ARE READ FROM TWO RECORDS IN
C*  THE FORMAT(5F13.10):
C*     S0  = MEAN LONGITUDE OF THE MOON (CYCLES) AT 000 ET 1/1/1976.
C*     H0  = MEAN LONGITUDE OF THE SUN.
C*     P0  = MEAN LONGITUDE OF THE LUNAR PERIGEE.
C*     ENP0= NEGATIVE OF THE MEAN LONGITUDE OF THE ASCENDING NODE.
C*     PP0 = MEAN LONGITUDE OF THE SOLAR PERIGEE (PERIHELION).
C*     DS,DH,DP,DNP,DPP ARE THEIR RESPECTIVE RATES OF CHANGE OVER A 365
C*     DAY PERIOD AS OF 000 ET 1/1/1976.
C
      subroutine vt_read_constituent_db(name_constituent_db)

      implicit none
      character*80 :: name_constituent_db
      integer, parameter :: MC=70     !todo: many redundant entries
      integer, parameter :: MC2=MC*2
      integer :: kr=8

      real*8 dpp,ds,dp,dnp,dh
      !real*8 p, tau, dtau
      real*8 s0,h0,p0,enp0,pp0

      integer :: jbase,j1,jl ! todo: more global than this?
      integer :: j,k,k1,j4
      !integer index(nmaxall)
      open(unit=KR,file=name_constituent_db)

c	These values are no longer used though they are still
c	read in. More accurate polynomial approximations are
c	now employed.
      READ(KR,50)S0,H0,P0,ENP0,PP0,DS,DH,DP,DNP,DPP
 50   FORMAT(5F13.10)
C
C***********************************************************************
C*  HERE THE MAIN CONSTITUENTS AND THEIR DOODSON NUMBERS ARE READ IN
C*  FORMAT (6X,A5,1X,6I3,F5.2,I4). THE VALUES ARE RESPECTIVELY
C*     KON    = CONSTITUENT NAME
C*  II,JJ,KK,LL,MM,NN = THE SIX DOODSON NUMBERS
C*     SEMI   = PHASE CORRECTION
C*     NJ     = THE NUMBER OF SATELLITES FOR THIS CONSTITUENT.
C*  THE END OF ALL MAIN CONSTITUENTS IS DENOTED BY A BLANK CARD.
C
      JBASE=0
      DO 90 K=1,1000
      READ(KR,60)KON(K),II(K),JJ(K),KK(K),LL(K),MM(K),NN(K),SEMI(K),NJ(K)
      IF(len_trim(KON(K)) == 0) go to 100
70    J1=JBASE+1
      IF(NJ(K).GE.1) GO TO 75
      NJ(K)=1
      JL=J1
      PH(J1)=0.
      EE(J1)=0.
      LDEL(J1)=0
      MDEL(J1)=0
      NDEL(J1)=0
      IR(J1)=0
      GO TO 90
75    JL=JBASE+NJ(K)
C
C***********************************************************************
C*  IF NJ>0, INFORMATION ON THE SATELLITE CONSTITUENTS IS READ , THREE
C*  SATELLITES PER CARD, IN THE FORMAT (11X,3(3I3,F4.2,F7.4,1X,I1,1X)).
C*  FOR EACH SATELLITE THE VALUES READ ARE
C*     LDEL,MDEL,NDEL = THE CHANGES IN THE LAST THREE DOODSON NUMBERS
C*                  FROM THOSE OF THE MAIN CONSTITUENT.
C*     PH     = THE PHASE CORRECTION
C*     EE     = THE AMPLITUDE RATIO OF THE SATELLITE TIDAL POTENTIAL TO
C*            THAT OF THE MAIN CONSTITUENT.
C*     IR     = 1 IF THE AMPLITUDE RATIO HAS TO BE MULTIPLIED BY THE
C*            LATITUDE CORRECTION FACTOR FOR DIURNAL CONSTITUENTS
C*            2 IF THE AMPLITUDE RATIO HAS TO BE MULTIPLIED BY THE
C*            LATITUDE CORRECTION FACTOR FOR SEMI-DIURNAL CONSTI-
C*            TUENTS.
C*            OTHERWISE IF NO CORRECTION IS REQUIRED TO THE AMPLITUDE
C*            RATIO.
C
      READ(KR,80)(LDEL(J),MDEL(J),NDEL(J),PH(J),EE(J),IR(J),J=J1,JL)
90    JBASE=JL
60    FORMAT(6X,A5,1X,6I3,F5.2,I4)
80    FORMAT((11X,3(3I3,F4.2,F7.4,1X,I1,1X)))
100   NTIDAL=K-1
C
C***********************************************************************
C*  THE SHALLOW WATER CONSTITUENTS AND THE MAIN CONSTITUENTS FROM WHICH
C*  THEY ARE DERIVED ARE READ IN HERE WITH THE FORMAT
C*  (6X,A5,I1,2X,4(F5.2,A5,5X)). THE VALUES ARE RESPECTIVELY
C*     KON    = NAME  OF THE SHALLOW WATER CONSTITUENT
C*     NJ     = NUMBER OF MAIN CONSTITUENTS FROM WHICH IT IS DERIVED.
C*     COEF,KONCO = COMBINATION NUMBER AND NAME OF THESE MAIN
C*              CONSTITUENTS.
C*  THE END OF THESE CONSTITUENTS IS DENOTED BY A BLANK CARD.
C
      JBASE=0
      K1=NTIDAL+1
      DO 160 K=K1,1000
      J1=JBASE+1
      J4=J1+3
      READ(KR,130)KON(K),NJ(K),(COEF(J),KONCO(J),J=J1,J4)
      IF(len_trim(KON(K)) == 0) go to 170
160   JBASE=JBASE+NJ(K)
130   FORMAT(6X,A5,I1,2X,4(F5.2,A5,5X))
170   NTOTAL=K-1
      RETURN
      end subroutine
C
C***********************************************************************
C*  NTIDAL IS THE NUMBER OF MAIN CONSTITUENTS
C*  NTOTAL IS THE NUMBER OF CONSTITUENTS (MAIN + SHALLOW WATER)
C*  FOR  THE GIVEN TIME hr, THE TABLE OF F AND V+U VALUES IS
C*  CALCULATED FOR ALL THE CONSTITUENTS.
C*     F IS THE NODAL MODULATION ADJUSTMENT FACTOR FOR AMPLITUDE
C*     U IS THE NODAL MODULATION ADJUSTMENT FACTOR FOR PHASE
C*     V IS THE ASTRONOMICAL ARGUMENT ADJUSTMENT FOR PHASE.
c
c	setvuf calculates the V,u,f values at time hr for all constituents
C
      subroutine SETVUF(hr,xlat,mf,name)
      !use analysis_request ! todo this dependency should be changed to an argument
      implicit none
      integer :: mf
      character*5, dimension(mf) :: name
      !integer mc,mc2
      !parameter (MC=70,MC2=MC*2)
      real*8 :: xlat
      real*8 d1,h,pp,s,p,enp,dh,dpp,ds,dp,dnp,hh,tau,dtau,hr

      integer indx(nmaxall)
      integer kd0,int24,intdys,jbase,k,L
      integer iv,j1,jL,iuu
      integer j
      real*8 vdbl ! todo: Correct type?
      real*8 slat,sumc,sums,rr,uudbl,uu,vv
      integer k1,iflag,lk,km1,lp

      SLAT=SIN(PI*XLAT/180.)
c      CALL GDAY(1,1,76,19,KD)
c      YEARS=(hr/24.D0-KD)/365.00D0
C
C***********************************************************************
C*  THE ASTRONOMICAL ARGUMENTS ARE CALCULATED BY LINEAR APPROXIMATION
C*  AT THE MID POINT OF THE ANALYSIS PERIOD.
C
c      S=S0+YEARS*DS
c      H=H0+YEARS*DH
c      P=P0+YEARS*DP
c      ENP=ENP0+YEARS*DNP
c      PP=PP0+YEARS*DPP
c	day number measured from January 0.5 1900 (i.e.,
c	1200 UT December 31, 1899
      d1=hr/24.d0
      call gday(31,12,99,18,kd0)
      d1=d1-dfloat(kd0)-0.5d0
      call astr(d1,h,pp,s,p,enp,dh,dpp,ds,dp,dnp)
      INT24=24
      INTDYS=int((hr+0.00001)/INT24)
      HH=hr-dfloat(INTDYS*INT24)
      TAU=HH/24.D0+H-S
      dtau=365.d0+dh-ds
C
C***********************************************************************
C*  ONLY THE FRACTIONAL PART OF A SOLAR DAY NEED BE RETAINED FOR COMPU-
C*  TING THE LUNAR TIME TAU.
C
      JBASE=0
      DO 210 K=1,NTIDAL
      do 209 l=1,mf    !todo make sure we have access
      if(kon(k).eq.name(l)) then
c      FREQ(l)=(II(K)*DTAU+JJ(K)*DS+KK(K)*DH+LL(K)*DP+MM(K)*DNP+
c     1NN(K)*DPP)/(365.*24.)
      indx(k)=l
      end if
209   continue
      VDBL=II(K)*TAU+JJ(K)*S+KK(K)*H+LL(K)*P+MM(K)*ENP+NN(K)*PP+SEMI(K)
      IV=VDBL
      IV=(IV/2)*2
      Vv=VDBL-IV            ! rounded to 2?
      J1=JBASE+1
      JL=JBASE+NJ(K)
      SUMC=1.
      SUMS=0.
      DO 200 J=J1,JL
C
C***********************************************************************
C*  HERE THE SATELLITE AMPLITUDE RATIO ADJUSTMENT FOR LATITUDE IS MADE
C
      RR=EE(J)
      L=IR(J)+1
      GO TO (901,902,903),L
  902 RR=EE(J)*0.36309*(1.-5.*SLAT*SLAT)/SLAT
      GO TO 901
  903 RR=EE(J)*2.59808*SLAT
  901 CONTINUE
      UUDBL=LDEL(J)*P+MDEL(J)*ENP+NDEL(J)*PP+PH(J)
      IUU=UUDBL
      UU=UUDBL-IUU
      SUMC=SUMC+RR*COS(UU*TWOPI)
      SUMS=SUMS+RR*SIN(UU*TWOPI)
  200 CONTINUE
      F(K)=SQRT(SUMC*SUMC+SUMS*SUMS)
      v(k)=vv
      U(K)=ATAN2(SUMS,SUMC)/TWOPI
210   JBASE=JL
C
C***********************************************************************
C*  HERE F AND V+U OF THE SHALLOW WATER CONSTITUENTS ARE COMPUTED FROM
C*  THE VALUES OF THE MAIN CONSTITUENT FROM WHICH THEY ARE DERIVED.
C
      JBASE=0
      K1=NTIDAL+1
      IF(K1.GT.NTOTAL) RETURN
      DO 270 K=K1,NTOTAL
      F(K)=1.0
      V(K)=0.0
      u(k)=0.
      iflag=0
      do 269 lk=1,mf
      if(kon(k).eq.name(lk)) then
c      FREQ(lk)=0.
      iflag=1
      go to 268
      end if
269   continue
268   J1=JBASE+1
      JL=JBASE+NJ(K)
      DO 260 J=J1,JL
      KM1=K-1
      DO 240 L=1,KM1
      IF(KON(L).eq.KONCO(J)) go to 250
240   CONTINUE
      WRITE(LP,241)KONCO(J)
241   FORMAT('  SETVUF STOP.',A5)
      STOP
250   F(K)=F(K)*F(L)**ABS(COEF(J))
      V(K)=V(K)+COEF(J)*V(L)
      U(K)=U(K)+COEF(J)*U(L)
c      if(iflag.eq.1) FREQ(lk)=FREQ(lk)+COEF(J)*FREQ(indx(L))
260   continue
270   JBASE=JL
      RETURN
      END subroutine

      end module


program test_gausshermite

use share, only: dp

implicit none

real(dp) :: x(100),ghfun(100)
real(dp) :: par(8)
integer:: i,j

do i=1,100
	x(i)=real(i)-1.0
enddo

par(1:8)=(/1.0000000  ,     50.000000  ,     1.6529296  ,     1.0000000,   &
-0.019545138 ,    -0.32213661  ,  -0.011828149   ,   0.15485563/)

call gausshermite(x,100,par,8,ghfun)

do i=1,100
write(*,*)ghfun(i)
enddo

end program test_gausshermite


!============================================================================
! EL PROGRAMA REALIZA EL CALCULO DE LA GDR APARTIR DE LAS DIFERENTES
! CONFIGURACIONES REALIZADAS EN EL PROGRAMA PRINCIPAL (3D)
!
! AUTOR: MARTIN ALEJANDRO PAREDES SOSA
!============================================================================

Subroutine GdrCalc

  Use cte
  Implicit None

  Integer, Allocatable, Dimension(:) :: Histo
  Real, Parameter :: delTar = 0.05
  Integer :: MBin, iBin
  Integer :: i, j, k                                              !CONTADORES
  Real :: xO, yO, zO, xN, yN, zN, xON, yON, zON
  Real :: rD, rU, rL, rM, c1, c2, gdr, gdrm, press
  Integer :: istat1
  Character (len=80) :: err_msg1
  logical :: Ctrl1, Ctrl2

  MBin = Int( RCut / delTar )
  Allocate( Histo(MBin) , STAT = istat1, ERRMSG = err_msg1)
  Histo = 0

  PartiO : Do i = 1, N

     NextParti : Do j = 1, N

        NOTSAME : If (i /= j ) Then

           StepCnfg : Do k = 1, NN

              !PARTICULA i ORIGEN
              xO = CX( i , k )
              yO = CY( i , k )
              zO = CZ( i , k )

              !PARTICUAL j CERCANA
              xN = CX( j , k )
              yN = CY( j , k )
              zN = CZ( j , k )

              !DISTANCIA
              xON = xN - xO
              yON = yN - yO
              zON = zN - zO

              !CONDICION DE IMAGEN MINIMA
              xON = xON - BoxL*Anint( xON/BoxL )
              yON = yON - BoxL*Anint( yON/BoxL )
              zON = zON - BoxL*Anint( zON/BoxL )

              !DISTANCIA ENTRE LAS PARTICULAS
              rD = sqrt( (xON * xON) + (yON * yON) + (zON*zON) )

              !CERCANIA CINTA
              iBin =  Int( rD / delTar ) + 1

              Guardar : If((iBin .LE. MBin)  ) Then

                 Histo(iBin) = Histo(iBin) + 1

              End If Guardar

           End Do StepCnfg

        End If NOTSAME

     End Do NextParti

  End Do PartiO

  c1 = ( 4.0 / 3.0 ) * PI * Dens

  !ABRIENDO ARCHIVO PARA GDR
  Open( 5, file= "gdr.dat" )

  GdrCal: Do ibin = 1 , MBin

     rL = Real(iBin - 1) * delTar

     rU = rL + delTar
     rM = rL + ( delTar/2.0 )

     c2 = c1 * ( ( rU**3 ) - ( rL**3 ) )
     gdr = Real( Histo(iBin) )/ Real(NN) / Real(N) / c2
     gdrm = gdr

     Write(5,*) rM , gdr

     !Ctrl1 = gdrm == 0                                        !CALCULO DE GDR ESFERA DURA
     !Ctrl2 = gdr /= 0
     !PressCalc:If ( Ctrl1 .AND. Ctrl2 ) Then
     !   Press = 1.0 + 0.5*PI*dens*gdr
     !   !Write(*,*) gdrm, gdr, press
     !End If PressCalc

  End Do GdrCal

  Close(5)

  Deallocate( Histo )

  Write(*,*) "GDR DONE, SAVE"

End Subroutine GdrCalc


SUBROUTINE FilterInit(filtercoefficients,filtercoefficients2)

USE Precision
USE GlobalVariables, ONLY: tmpfilter,filterNP,filterALPHA,filterORDER,sigma_filt,fileop
USE Constants
!
! Set up the filtering coefficients.  The variables tmpfilter, filtercoefficients
! and filtercoefficients2 have all been allocated and initialized to zero in
! ReadInputFileParameters.f90.
!
! filtercoefficients(1:filterNP):  The centered S-G filter
! filtercoefficients(1:filterNP,filterAlpha):  The off-centered coefficients towards a boundary
!
! The off-centered coefficients of Berland et al JCP (2007) are applied to the
! first 3 boundary points with the weights given by sigma_filt, then centered S-G filters
! are used up to point 6.  We assume that filterAlpha<=6.
!
!  If sigma_filt(1)=0, then the boundary filtering is turned off.

IMPLICIT NONE

INTEGER         :: i
REAL(KIND=long) :: filtercoefficients(filterNP),   &
     filtercoefficients2(max(filterNP,13),max(filterAlpha,6))
!
! Determine Savitzky-Golay filter
! filtercoefficients contains the centered SG-filter applied inside domain
!
CALL savgol(tmpfilter,filterNP,filterALPHA,filterALPHA,0,filterORDER)
! REORDER COEFFICIENTS
filtercoefficients(filterALPHA+1) = tmpfilter(1)
filtercoefficients(1:filterALPHA) = tmpfilter((filterALPHA+1):2:-1)
filtercoefficients((filterALPHA+2):filterNP) = tmpfilter(filterNP:(filterALPHA+2):-1)
!
! Different ways to treat the boundaries (case 4- seems to be the best choice)
! One has to adapt the filtering close to boundaries
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 1- General off-centered Savitzky-Golay filter: NOT WORKING, amplification at some wavenumbers
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!$$$$$$ DO i=1,filterALPHA
!$$$$$$    ! Determine off-centered Savitzky-Golay filter
!$$$$$$    CALL savgol(tmpfilter,filterNP,i-1,filterNP-i,0,filterORDER)
!$$$$$$    ! REORDER COEFFICIENTS
!$$$$$$    filtercoefficients2(i,i)=tmpfilter(1)
!$$$$$$    filtercoefficients2(1:i-1,i)=tmpfilter(i:2:-1)
!$$$$$$    filtercoefficients2(i+1:filterNP,i)=tmpfilter(filterNP:i+1:-1)
!$$$$$$ ENDDO
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 2- Determine the coefficients assuming symetry on the boundary...
! FIXME: shall we use filtering on global variable ? ... (eg. for free propagation, not optimal)
! NOT WORKING in a general case
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!$$$$$$ filtercoefficients2(1:filterNP,1:filterALPHA) = zero
!$$$$$$ DO i=1,filterALPHA
!$$$$$$   filtercoefficients2(1:filterALPHA+i,i) = filtercoefficients(filterALPHA-i+2:filterNP)
!$$$$$$   DO j=1,filterALPHA-i+1
!$$$$$$     filtercoefficients2(1+j,i)=filtercoefficients2(1+j,i)+filtercoefficients(filterALPHA+1-j-i+1)
!$$$$$$   ENDDO
!$$$$$$ ENDDO
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 3- ! GD: optimize the filtering close to the boundaries
! We use the ghost points now, i.e. first point uses 1 point on the left and some points on the right...
! FIXME find a way to generalize the process... (plus, not working perfectly...)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!$$$$$$ filterALPHA = 6
!$$$$$$ filterNP = 2*filterALPHA+1
!$$$$$$ filterORDER = 10
!$$$$$$ !
!$$$$$$ DEALLOCATE(filtercoefficients,tmpfilter,filtercoefficients2)
!$$$$$$ ALLOCATE(filtercoefficients(filterNP),tmpfilter(filterNP),filtercoefficients2(filterNP,filterALPHA))
!$$$$$$ ALLOCATE(filtercoefficients3(filterNP,filterALPHA))
!$$$$$$ filtercoefficients = zero; tmpfilter = zero; filtercoefficients2 = zero
!$$$$$$ !
!$$$$$$ ! Determine Savitzky-Golay filter : centered scheme
!$$$$$$ CALL savgol(tmpfilter,filterNP,filterALPHA,filterALPHA,0,filterORDER)
!$$$$$$ ! REORDER COEFFICIENTS
!$$$$$$ filtercoefficients(filterALPHA+1) = tmpfilter(1)
!$$$$$$ filtercoefficients(1:filterALPHA) = tmpfilter((filterALPHA+1):2:-1)
!$$$$$$ filtercoefficients((filterALPHA+2):filterNP) = tmpfilter(filterNP:(filterALPHA+2):-1)
!$$$$$$
!$$$$$$ !Off-centered scheme
!$$$$$$      ! First point no filter : test
!$$$$$$      i=1
!$$$$$$      ! First point
!$$$$$$      CALL savgol(tmpfilter,5,1,3,0,2)
!$$$$$$ !$$$$$$      CALL savgol(tmpfilter,13,1,11,0,2)
!$$$$$$      i=1
!$$$$$$      filtercoefficients2(i+1,i)=tmpfilter(1)
!$$$$$$      filtercoefficients2(1:i,i)=tmpfilter(i+1:2:-1)
!$$$$$$      filtercoefficients2(i+2:5,i)=tmpfilter(5:i+2:-1)
!$$$$$$ !$$$$$$      filtercoefficients2(i+2:13,i)=tmpfilter(13:i+2:-1)
!$$$$$$
!$$$$$$      ! Second point no filter : test
!$$$$$$      i=2
!$$$$$$      ! Second point
!$$$$$$      CALL savgol(tmpfilter,7,2,4,0,3)
!$$$$$$ !$$$$$$      CALL savgol(tmpfilter,13,2,10,0,2)
!$$$$$$      i=2
!$$$$$$      filtercoefficients2(i+1,i)=tmpfilter(1)
!$$$$$$      filtercoefficients2(1:i,i)=tmpfilter(i+1:2:-1)
!$$$$$$      filtercoefficients2(i+2:7,i)=tmpfilter(7:i+2:-1)
!$$$$$$      ! Third point
!$$$$$$      CALL savgol(tmpfilter,7,3,3,0,4)
!$$$$$$ !$$$$$$      CALL savgol(tmpfilter,13,3,9,0,2)
!$$$$$$      i=3
!$$$$$$      filtercoefficients2(i+1,i)=tmpfilter(1)
!$$$$$$      filtercoefficients2(1:i,i)=tmpfilter(i+1:2:-1)
!$$$$$$      filtercoefficients2(i+2:7,i)=tmpfilter(7:i+2:-1)
!$$$$$$ !$$$$$$      filtercoefficients2(i+2:13,i)=tmpfilter(13:i+2:-1)
!$$$$$$      ! Fourth point
!$$$$$$      CALL savgol(tmpfilter,9,4,4,0,5)
!$$$$$$ !$$$$$$      CALL savgol(tmpfilter,13,4,8,0,2)
!$$$$$$      i=4
!$$$$$$      filtercoefficients2(i+1,i)=tmpfilter(1)
!$$$$$$      filtercoefficients2(1:i,i)=tmpfilter(i+1:2:-1)
!$$$$$$      filtercoefficients2(i+2:9,i)=tmpfilter(9:i+2:-1)
!$$$$$$ !$$$$$$      filtercoefficients2(i+2:13,i)=tmpfilter(13:i+2:-1)
!$$$$$$      ! Fifth point
!$$$$$$      CALL savgol(tmpfilter,11,5,5,0,7)
!$$$$$$ !$$$$$$      CALL savgol(tmpfilter,13,5,7,0,2)
!$$$$$$      i=5
!$$$$$$      filtercoefficients2(i+1,i)=tmpfilter(1)
!$$$$$$      filtercoefficients2(1:i,i)=tmpfilter(i+1:2:-1)
!$$$$$$      filtercoefficients2(i+2:11,i)=tmpfilter(11:i+2:-1)
!$$$$$$      ! Six point and other points with centered schemes...
!$$$$$$      CALL savgol(tmpfilter,filterNP,filterALPHA,filterALPHA,0,filterORDER)
!$$$$$$      i=filterALPHA
!$$$$$$      filtercoefficients2(i+1,i)=tmpfilter(1)
!$$$$$$      filtercoefficients2(1:i,i)=tmpfilter(i+1:2:-1)
!$$$$$$      filtercoefficients2(i+2:filterNP,i)=tmpfilter(filterNP:i+2:-1)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 4- other choice of filtering not taking into account ghost point...
! We use the optimized off-centered filters of Berland et al. (2007)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! other choice of filtering not taking into account ghost point...
!
! First point no filter : test
filtercoefficients2=zero
i=1
filtercoefficients2(i,i)=1.d0
! First point, filter from Berland et al. (JCP 2007)
tmpfilter=zero
tmpfilter(1) = 0.320882352941
tmpfilter(2) = -0.465
tmpfilter(3) = 0.179117647059
tmpfilter(4) = -0.035
filtercoefficients2(:,i)=filtercoefficients2(:,i)-sigma_filt(1)*tmpfilter(:)
tmpfilter=zero
! Second point : test
i=2
filtercoefficients2(i,i)=1.d0
! Second point, filter from Berland et al. (JCP 2007)
tmpfilter=zero
tmpfilter(1) = -0.085777408970
tmpfilter(2) = 0.277628171524
tmpfilter(3) = -0.356848072173
tmpfilter(4) = 0.223119093072
tmpfilter(5) = -0.057347064865
tmpfilter(6) = -0.000747264596
tmpfilter(7) = -0.000027453993
filtercoefficients2(:,i)=filtercoefficients2(:,i)-sigma_filt(2)*tmpfilter(:)
tmpfilter=zero

! Third point : test
i=3
filtercoefficients2(i,i)=1.d0
! Third point, filter from Berland et al. (JCP 2007)
tmpfilter=zero
tmpfilter(1) = 0.052523901012
tmpfilter(2) = -0.206299133811
tmpfilter(3) = 0.353527998250
tmpfilter(4) = -0.348142394842
tmpfilter(5) = 0.181481803619
tmpfilter(6) = 0.009440804370
tmpfilter(7) = -0.077675100452
tmpfilter(8) = 0.044887364863
tmpfilter(9) = -0.009971961849
tmpfilter(10)= 0.000113359420
tmpfilter(11)= 0.000113359420
filtercoefficients2(:,i)=filtercoefficients2(:,i)-sigma_filt(3)*tmpfilter(:)
tmpfilter=zero
! Fourth point
CALL savgol(tmpfilter,7,3,3,0,5)
i=4
filtercoefficients2(i,i)=tmpfilter(1)
filtercoefficients2(1:i-1,i)=tmpfilter(i:2:-1)
filtercoefficients2(i+1:7,i)=tmpfilter(7:i+1:-1)

! Fifth point
CALL savgol(tmpfilter,9,4,4,0,6)
i=5
filtercoefficients2(i,i)=tmpfilter(1)
filtercoefficients2(1:i-1,i)=tmpfilter(i:2:-1)
filtercoefficients2(i+1:9,i)=tmpfilter(9:i+1:-1)

! Six point
CALL savgol(tmpfilter,11,5,5,0,8)
i=6
filtercoefficients2(i,i)=tmpfilter(1)
filtercoefficients2(1:i-1,i)=tmpfilter(i:2:-1)
filtercoefficients2(i+1:11,i)=tmpfilter(11:i+1:-1)
!
DEALLOCATE(tmpfilter)
!
! Turn off the boundary filtering if sigma_filt(1)=0
!
!
if(abs(sigma_filt(1))<1.e-12)then
   print *, 'FilterInit:  Boundary filtering is turned off.'
   print *, ' '
   write(fileop(1),*) 'FilterInit:  Boundary filtering is turned off.'
   write(fileop(1),*) ' '
   filtercoefficients2=zero
   do i=1,max(filterALPHA,6)
      filtercoefficients2(i,i)=one
   end do
else
   print *, 'FilterInit:  Boundary filtering is turned on with values:'
   print *, sigma_filt
   print *, ' '
   write(fileop(1),*) 'FilterInit:  Boundary filtering is turned on with values:'
   write(fileop(1),*) sigma_filt
   write(fileop(1),*) ' '

end if

END SUBROUTINE FilterInit


C     SUBROUTINE CFFTF(N,C,WSAVE)
C
C     SUBROUTINE CFFTF COMPUTES THE FORWARD COMPLEX DISCRETE FOURIER
C     TRANSFORM (THE FOURIER ANALYSIS). EQUIVALENTLY , CFFTF COMPUTES
C     THE FOURIER COEFFICIENTS OF A COMPLEX PERIODIC SEQUENCE.
C     THE TRANSFORM IS DEFINED BELOW AT OUTPUT PARAMETER C.
C
C     THE TRANSFORM IS NOT NORMALIZED. TO OBTAIN A NORMALIZED TRANSFORM
C     THE OUTPUT MUST BE DIVIDED BY N. OTHERWISE A CALL OF CFFTF
C     FOLLOWED BY A CALL OF CFFTB WILL MULTIPLY THE SEQUENCE BY N.
C
C     THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE CFFTF MUST BE
C     INITIALIZED BY CALLING SUBROUTINE CFFTI(N,WSAVE).
C
C     INPUT PARAMETERS
C
C
C     N      THE LENGTH OF THE COMPLEX SEQUENCE C. THE METHOD IS
C            MORE EFFICIENT WHEN N IS THE PRODUCT OF SMALL PRIMES. N
C
C     C      A COMPLEX ARRAY OF LENGTH N WHICH CONTAINS THE SEQUENCE
C
C     WSAVE   A REAL WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 4N+15
C             IN THE PROGRAM THAT CALLS CFFTF. THE WSAVE ARRAY MUST BE
C             INITIALIZED BY CALLING SUBROUTINE CFFTI(N,WSAVE) AND A
C             DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT
C             VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE
C             REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT
C             TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST.
C             THE SAME WSAVE ARRAY CAN BE USED BY CFFTF AND CFFTB.
C
C     OUTPUT PARAMETERS
C
C     C      FOR J=1,...,N
C
C                C(J)=THE SUM FROM K=1,...,N OF
C
C                      C(K)*EXP(-I*(J-1)*(K-1)*2*PI/N)
C
C                            WHERE I=SQRT(-1)
C
C     WSAVE   CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT BE
C             DESTROYED BETWEEN CALLS OF SUBROUTINE CFFTF OR CFFTB
C
      SUBROUTINE CFFTF(N,C,WSAVE)
      DOUBLE PRECISION C
      DOUBLE PRECISION WSAVE
      DIMENSION C(*),WSAVE(*)
C
      IF (N.EQ.1) RETURN
      IW1 = N + N + 1
      IW2 = IW1 + N + N
      CALL CFFTF1(N,C,WSAVE,WSAVE(IW1),WSAVE(IW2))
      RETURN
      END


      subroutine fcube(t,f,fp,ta,fa,fpa,tlower,tupper)
c     Copyright INRIA
      implicit double precision (a-h,o-z)
c
c           Using f and fp at t and ta, computes new t by cubic formula
c           safeguarded inside [tlower,tupper].
c
      z1=fp+fpa-3.d0*(fa-f)/(ta-t)
      b=z1+fp
c
c              first compute the discriminant (without overflow)
c
      if (dabs(z1).le.1.d0) then
          discri=z1*z1-fp*fpa
        else
          discri=fp/z1
          discri=discri*fpa
          discri=z1-discri
          if (z1.ge.0.d0 .and. discri.ge.0.d0) then
              discri=dsqrt(z1)*dsqrt(discri)
              go to 200
          endif
          if (z1.le.0.d0 .and. discri.le.0.d0) then
              discri=dsqrt(-z1)*dsqrt(-discri)
              go to 200
          endif
          discri=-1.d0
      endif
      if (discri.lt.0.d0) then
          if (fp.lt.0.d0) t=tupper
          if (fp.ge.0.d0) t=tlower
          go to 990
      endif
c
c       discriminant nonnegative, stable solution formula
c
      discri=dsqrt(discri)
  200 if (t-ta.lt.0.d0) discri=-discri
      sign=(t-ta)/dabs(t-ta)
      if (b*sign.gt.0.) then
          anum=(ta-t)*fp
          den=b+discri
        else
          den=z1+b+fpa
          anum=(ta-t)*(b-discri)
      endif
c
c               now compute the ratio (without overflow)
c
      if (dabs(den).ge.1.d0) then
          t=t+anum/den
        else
          if (dabs(anum).lt.(tupper-tlower)*dabs(den)) then
              t=t+anum/den
            else
              if (fp.lt.0.d0) t=tupper
              if (fp.ge.0.d0) t=tlower
          endif
      endif
c
c                       finally, safeguard
c
      t=dmax1(t,tlower)
      t=dmin1(t,tupper)
  990 return
      end


!*==ztgsyl.f90  processed by SPAG 7.51RB at 20:09 on  3 Mar 2022
!> \brief \b ZTGSYL
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download ZTGSYL + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE ZTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D,
!                          LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK,
!                          IWORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          TRANS
!       INTEGER            IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF,
!      $                   LWORK, M, N
!       DOUBLE PRECISION   DIF, SCALE
!       ..
!       .. Array Arguments ..
!       INTEGER            IWORK( * )
!       COMPLEX*16         A( LDA, * ), B( LDB, * ), C( LDC, * ),
!      $                   D( LDD, * ), E( LDE, * ), F( LDF, * ),
!      $                   WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> ZTGSYL solves the generalized Sylvester equation:
!>
!>             A * R - L * B = scale * C            (1)
!>             D * R - L * E = scale * F
!>
!> where R and L are unknown m-by-n matrices, (A, D), (B, E) and
!> (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n,
!> respectively, with complex entries. A, B, D and E are upper
!> triangular (i.e., (A,D) and (B,E) in generalized Schur form).
!>
!> The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1
!> is an output scaling factor chosen to avoid overflow.
!>
!> In matrix notation (1) is equivalent to solve Zx = scale*b, where Z
!> is defined as
!>
!>        Z = [ kron(In, A)  -kron(B**H, Im) ]        (2)
!>            [ kron(In, D)  -kron(E**H, Im) ],
!>
!> Here Ix is the identity matrix of size x and X**H is the conjugate
!> transpose of X. Kron(X, Y) is the Kronecker product between the
!> matrices X and Y.
!>
!> If TRANS = 'C', y in the conjugate transposed system Z**H *y = scale*b
!> is solved for, which is equivalent to solve for R and L in
!>
!>             A**H * R + D**H * L = scale * C           (3)
!>             R * B**H + L * E**H = scale * -F
!>
!> This case (TRANS = 'C') is used to compute an one-norm-based estimate
!> of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D)
!> and (B,E), using ZLACON.
!>
!> If IJOB >= 1, ZTGSYL computes a Frobenius norm-based estimate of
!> Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the
!> reciprocal of the smallest singular value of Z.
!>
!> This is a level-3 BLAS algorithm.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] TRANS
!> \verbatim
!>          TRANS is CHARACTER*1
!>          = 'N': solve the generalized sylvester equation (1).
!>          = 'C': solve the "conjugate transposed" system (3).
!> \endverbatim
!>
!> \param[in] IJOB
!> \verbatim
!>          IJOB is INTEGER
!>          Specifies what kind of functionality to be performed.
!>          =0: solve (1) only.
!>          =1: The functionality of 0 and 3.
!>          =2: The functionality of 0 and 4.
!>          =3: Only an estimate of Dif[(A,D), (B,E)] is computed.
!>              (look ahead strategy is used).
!>          =4: Only an estimate of Dif[(A,D), (B,E)] is computed.
!>              (ZGECON on sub-systems is used).
!>          Not referenced if TRANS = 'C'.
!> \endverbatim
!>
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>          The order of the matrices A and D, and the row dimension of
!>          the matrices C, F, R and L.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrices B and E, and the column dimension
!>          of the matrices C, F, R and L.
!> \endverbatim
!>
!> \param[in] A
!> \verbatim
!>          A is COMPLEX*16 array, dimension (LDA, M)
!>          The upper triangular matrix A.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1, M).
!> \endverbatim
!>
!> \param[in] B
!> \verbatim
!>          B is COMPLEX*16 array, dimension (LDB, N)
!>          The upper triangular matrix B.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >= max(1, N).
!> \endverbatim
!>
!> \param[in,out] C
!> \verbatim
!>          C is COMPLEX*16 array, dimension (LDC, N)
!>          On entry, C contains the right-hand-side of the first matrix
!>          equation in (1) or (3).
!>          On exit, if IJOB = 0, 1 or 2, C has been overwritten by
!>          the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R,
!>          the solution achieved during the computation of the
!>          Dif-estimate.
!> \endverbatim
!>
!> \param[in] LDC
!> \verbatim
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1, M).
!> \endverbatim
!>
!> \param[in] D
!> \verbatim
!>          D is COMPLEX*16 array, dimension (LDD, M)
!>          The upper triangular matrix D.
!> \endverbatim
!>
!> \param[in] LDD
!> \verbatim
!>          LDD is INTEGER
!>          The leading dimension of the array D. LDD >= max(1, M).
!> \endverbatim
!>
!> \param[in] E
!> \verbatim
!>          E is COMPLEX*16 array, dimension (LDE, N)
!>          The upper triangular matrix E.
!> \endverbatim
!>
!> \param[in] LDE
!> \verbatim
!>          LDE is INTEGER
!>          The leading dimension of the array E. LDE >= max(1, N).
!> \endverbatim
!>
!> \param[in,out] F
!> \verbatim
!>          F is COMPLEX*16 array, dimension (LDF, N)
!>          On entry, F contains the right-hand-side of the second matrix
!>          equation in (1) or (3).
!>          On exit, if IJOB = 0, 1 or 2, F has been overwritten by
!>          the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L,
!>          the solution achieved during the computation of the
!>          Dif-estimate.
!> \endverbatim
!>
!> \param[in] LDF
!> \verbatim
!>          LDF is INTEGER
!>          The leading dimension of the array F. LDF >= max(1, M).
!> \endverbatim
!>
!> \param[out] DIF
!> \verbatim
!>          DIF is DOUBLE PRECISION
!>          On exit DIF is the reciprocal of a lower bound of the
!>          reciprocal of the Dif-function, i.e. DIF is an upper bound of
!>          Dif[(A,D), (B,E)] = sigma-min(Z), where Z as in (2).
!>          IF IJOB = 0 or TRANS = 'C', DIF is not referenced.
!> \endverbatim
!>
!> \param[out] SCALE
!> \verbatim
!>          SCALE is DOUBLE PRECISION
!>          On exit SCALE is the scaling factor in (1) or (3).
!>          If 0 < SCALE < 1, C and F hold the solutions R and L, resp.,
!>          to a slightly perturbed system but the input matrices A, B,
!>          D and E have not been changed. If SCALE = 0, R and L will
!>          hold the solutions to the homogeneous system with C = F = 0.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          The dimension of the array WORK. LWORK > = 1.
!>          If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*N).
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!> \endverbatim
!>
!> \param[out] IWORK
!> \verbatim
!>          IWORK is INTEGER array, dimension (M+N+2)
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>            =0: successful exit
!>            <0: If INFO = -i, the i-th argument had an illegal value.
!>            >0: (A, D) and (B, E) have common or very close
!>                eigenvalues.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complex16SYcomputational
!
!> \par Contributors:
!  ==================
!>
!>     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
!>     Umea University, S-901 87 Umea, Sweden.
!
!> \par References:
!  ================
!>
!>  [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
!>      for Solving the Generalized Sylvester Equation and Estimating the
!>      Separation between Regular Matrix Pairs, Report UMINF - 93.23,
!>      Department of Computing Science, Umea University, S-901 87 Umea,
!>      Sweden, December 1993, Revised April 1994, Also as LAPACK Working
!>      Note 75.  To appear in ACM Trans. on Math. Software, Vol 22,
!>      No 1, 1996.
!> \n
!>  [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester
!>      Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal.
!>      Appl., 15(4):1045-1060, 1994.
!> \n
!>  [3] B. Kagstrom and L. Westin, Generalized Schur Methods with
!>      Condition Estimators for Solving the Generalized Sylvester
!>      Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7,
!>      July 1989, pp 745-751.
!>
!  =====================================================================
      SUBROUTINE ZTGSYL(Trans,Ijob,M,N,A,Lda,B,Ldb,C,Ldc,D,Ldd,E,Lde,F, &
     &                  Ldf,Scale,Dif,Work,Lwork,Iwork,Info)
      IMPLICIT NONE
!*--ZTGSYL298
!
!  -- LAPACK computational routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Trans
      INTEGER Ijob , Info , Lda , Ldb , Ldc , Ldd , Lde , Ldf , Lwork , &
     &        M , N
      DOUBLE PRECISION Dif , Scale
!     ..
!     .. Array Arguments ..
      INTEGER Iwork(*)
      COMPLEX*16 A(Lda,*) , B(Ldb,*) , C(Ldc,*) , D(Ldd,*) , E(Lde,*) , &
     &           F(Ldf,*) , Work(*)
!     ..
!
!  =====================================================================
!  Replaced various illegal calls to CCOPY by calls to CLASET.
!  Sven Hammarling, 1/5/02.
!
!     .. Parameters ..
      DOUBLE PRECISION ZERO , ONE
      PARAMETER (ZERO=0.0D+0,ONE=1.0D+0)
      COMPLEX*16 CZERO
      PARAMETER (CZERO=(0.0D+0,0.0D+0))
!     ..
!     .. Local Scalars ..
      LOGICAL lquery , notran
      INTEGER i , ie , ifunc , iround , is , isolve , j , je , js , k , &
     &        linfo , lwmin , mb , nb , p , pq , q
      DOUBLE PRECISION dscale , dsum , scale2 , scaloc
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      INTEGER ILAENV
      EXTERNAL LSAME , ILAENV
!     ..
!     .. External Subroutines ..
      EXTERNAL XERBLA , ZGEMM , ZLACPY , ZLASET , ZSCAL , ZTGSY2
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC DBLE , DCMPLX , MAX , SQRT
!     ..
!     .. Executable Statements ..
!
!     Decode and test input parameters
!
      Info = 0
      notran = LSAME(Trans,'N')
      lquery = (Lwork==-1)
!
      IF ( .NOT.notran .AND. .NOT.LSAME(Trans,'C') ) THEN
         Info = -1
      ELSEIF ( notran ) THEN
         IF ( (Ijob<0) .OR. (Ijob>4) ) Info = -2
      ENDIF
      IF ( Info==0 ) THEN
         IF ( M<=0 ) THEN
            Info = -3
         ELSEIF ( N<=0 ) THEN
            Info = -4
         ELSEIF ( Lda<MAX(1,M) ) THEN
            Info = -6
         ELSEIF ( Ldb<MAX(1,N) ) THEN
            Info = -8
         ELSEIF ( Ldc<MAX(1,M) ) THEN
            Info = -10
         ELSEIF ( Ldd<MAX(1,M) ) THEN
            Info = -12
         ELSEIF ( Lde<MAX(1,N) ) THEN
            Info = -14
         ELSEIF ( Ldf<MAX(1,M) ) THEN
            Info = -16
         ENDIF
      ENDIF
!
      IF ( Info==0 ) THEN
         IF ( .NOT.(notran) ) THEN
            lwmin = 1
         ELSEIF ( Ijob==1 .OR. Ijob==2 ) THEN
            lwmin = MAX(1,2*M*N)
         ELSE
            lwmin = 1
         ENDIF
         Work(1) = lwmin
!
         IF ( Lwork<lwmin .AND. .NOT.lquery ) Info = -20
      ENDIF
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('ZTGSYL',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( M==0 .OR. N==0 ) THEN
         Scale = 1
         IF ( notran ) THEN
            IF ( Ijob/=0 ) Dif = 0
         ENDIF
         RETURN
      ENDIF
!
!     Determine  optimal block sizes MB and NB
!
      mb = ILAENV(2,'ZTGSYL',Trans,M,N,-1,-1)
      nb = ILAENV(5,'ZTGSYL',Trans,M,N,-1,-1)
!
      isolve = 1
      ifunc = 0
      IF ( notran ) THEN
         IF ( Ijob>=3 ) THEN
            ifunc = Ijob - 2
            CALL ZLASET('F',M,N,CZERO,CZERO,C,Ldc)
            CALL ZLASET('F',M,N,CZERO,CZERO,F,Ldf)
         ELSEIF ( Ijob>=1 .AND. notran ) THEN
            isolve = 2
         ENDIF
      ENDIF
!
      IF ( (mb<=1 .AND. nb<=1) .OR. (mb>=M .AND. nb>=N) ) THEN
!
!        Use unblocked Level 2 solver
!
         DO iround = 1 , isolve
!
            Scale = ONE
            dscale = ZERO
            dsum = ONE
            pq = M*N
            CALL ZTGSY2(Trans,ifunc,M,N,A,Lda,B,Ldb,C,Ldc,D,Ldd,E,Lde,F,&
     &                  Ldf,Scale,dsum,dscale,Info)
            IF ( dscale/=ZERO ) THEN
               IF ( Ijob==1 .OR. Ijob==3 ) THEN
                  Dif = SQRT(DBLE(2*M*N))/(dscale*SQRT(dsum))
               ELSE
                  Dif = SQRT(DBLE(pq))/(dscale*SQRT(dsum))
               ENDIF
            ENDIF
            IF ( isolve==2 .AND. iround==1 ) THEN
               IF ( notran ) ifunc = Ijob
               scale2 = Scale
               CALL ZLACPY('F',M,N,C,Ldc,Work,M)
               CALL ZLACPY('F',M,N,F,Ldf,Work(M*N+1),M)
               CALL ZLASET('F',M,N,CZERO,CZERO,C,Ldc)
               CALL ZLASET('F',M,N,CZERO,CZERO,F,Ldf)
            ELSEIF ( isolve==2 .AND. iround==2 ) THEN
               CALL ZLACPY('F',M,N,Work,M,C,Ldc)
               CALL ZLACPY('F',M,N,Work(M*N+1),M,F,Ldf)
               Scale = scale2
            ENDIF
         ENDDO
!
         RETURN
!
      ENDIF
!
!     Determine block structure of A
!
      p = 0
      i = 1
      DO WHILE ( i<=M )
         p = p + 1
         Iwork(p) = i
         i = i + mb
         IF ( i>=M ) EXIT
      ENDDO
      Iwork(p+1) = M + 1
      IF ( Iwork(p)==Iwork(p+1) ) p = p - 1
!
!     Determine block structure of B
!
      q = p + 1
      j = 1
      DO WHILE ( j<=N )
!
         q = q + 1
         Iwork(q) = j
         j = j + nb
         IF ( j>=N ) EXIT
      ENDDO
!
      Iwork(q+1) = N + 1
      IF ( Iwork(q)==Iwork(q+1) ) q = q - 1
!
      IF ( notran ) THEN
         DO iround = 1 , isolve
!
!           Solve (I, J) - subsystem
!               A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J)
!               D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J)
!           for I = P, P - 1, ..., 1; J = 1, 2, ..., Q
!
            pq = 0
            Scale = ONE
            dscale = ZERO
            dsum = ONE
            DO j = p + 2 , q
               js = Iwork(j)
               je = Iwork(j+1) - 1
               nb = je - js + 1
               DO i = p , 1 , -1
                  is = Iwork(i)
                  ie = Iwork(i+1) - 1
                  mb = ie - is + 1
                  CALL ZTGSY2(Trans,ifunc,mb,nb,A(is,is),Lda,B(js,js),  &
     &                        Ldb,C(is,js),Ldc,D(is,is),Ldd,E(js,js),   &
     &                        Lde,F(is,js),Ldf,scaloc,dsum,dscale,linfo)
                  IF ( linfo>0 ) Info = linfo
                  pq = pq + mb*nb
                  IF ( scaloc/=ONE ) THEN
                     DO k = 1 , js - 1
                        CALL ZSCAL(M,DCMPLX(scaloc,ZERO),C(1,k),1)
                        CALL ZSCAL(M,DCMPLX(scaloc,ZERO),F(1,k),1)
                     ENDDO
                     DO k = js , je
                        CALL ZSCAL(is-1,DCMPLX(scaloc,ZERO),C(1,k),1)
                        CALL ZSCAL(is-1,DCMPLX(scaloc,ZERO),F(1,k),1)
                     ENDDO
                     DO k = js , je
                        CALL ZSCAL(M-ie,DCMPLX(scaloc,ZERO),C(ie+1,k),1)
                        CALL ZSCAL(M-ie,DCMPLX(scaloc,ZERO),F(ie+1,k),1)
                     ENDDO
                     DO k = je + 1 , N
                        CALL ZSCAL(M,DCMPLX(scaloc,ZERO),C(1,k),1)
                        CALL ZSCAL(M,DCMPLX(scaloc,ZERO),F(1,k),1)
                     ENDDO
                     Scale = Scale*scaloc
                  ENDIF
!
!                 Substitute R(I,J) and L(I,J) into remaining equation.
!
                  IF ( i>1 ) THEN
                     CALL ZGEMM('N','N',is-1,nb,mb,DCMPLX(-ONE,ZERO),   &
     &                          A(1,is),Lda,C(is,js),Ldc,               &
     &                          DCMPLX(ONE,ZERO),C(1,js),Ldc)
                     CALL ZGEMM('N','N',is-1,nb,mb,DCMPLX(-ONE,ZERO),   &
     &                          D(1,is),Ldd,C(is,js),Ldc,               &
     &                          DCMPLX(ONE,ZERO),F(1,js),Ldf)
                  ENDIF
                  IF ( j<q ) THEN
                     CALL ZGEMM('N','N',mb,N-je,nb,DCMPLX(ONE,ZERO),    &
     &                          F(is,js),Ldf,B(js,je+1),Ldb,            &
     &                          DCMPLX(ONE,ZERO),C(is,je+1),Ldc)
                     CALL ZGEMM('N','N',mb,N-je,nb,DCMPLX(ONE,ZERO),    &
     &                          F(is,js),Ldf,E(js,je+1),Lde,            &
     &                          DCMPLX(ONE,ZERO),F(is,je+1),Ldf)
                  ENDIF
               ENDDO
            ENDDO
            IF ( dscale/=ZERO ) THEN
               IF ( Ijob==1 .OR. Ijob==3 ) THEN
                  Dif = SQRT(DBLE(2*M*N))/(dscale*SQRT(dsum))
               ELSE
                  Dif = SQRT(DBLE(pq))/(dscale*SQRT(dsum))
               ENDIF
            ENDIF
            IF ( isolve==2 .AND. iround==1 ) THEN
               IF ( notran ) ifunc = Ijob
               scale2 = Scale
               CALL ZLACPY('F',M,N,C,Ldc,Work,M)
               CALL ZLACPY('F',M,N,F,Ldf,Work(M*N+1),M)
               CALL ZLASET('F',M,N,CZERO,CZERO,C,Ldc)
               CALL ZLASET('F',M,N,CZERO,CZERO,F,Ldf)
            ELSEIF ( isolve==2 .AND. iround==2 ) THEN
               CALL ZLACPY('F',M,N,Work,M,C,Ldc)
               CALL ZLACPY('F',M,N,Work(M*N+1),M,F,Ldf)
               Scale = scale2
            ENDIF
         ENDDO
      ELSE
!
!        Solve transposed (I, J)-subsystem
!            A(I, I)**H * R(I, J) + D(I, I)**H * L(I, J) = C(I, J)
!            R(I, J) * B(J, J)  + L(I, J) * E(J, J) = -F(I, J)
!        for I = 1,2,..., P; J = Q, Q-1,..., 1
!
         Scale = ONE
         DO i = 1 , p
            is = Iwork(i)
            ie = Iwork(i+1) - 1
            mb = ie - is + 1
            DO j = q , p + 2 , -1
               js = Iwork(j)
               je = Iwork(j+1) - 1
               nb = je - js + 1
               CALL ZTGSY2(Trans,ifunc,mb,nb,A(is,is),Lda,B(js,js),Ldb, &
     &                     C(is,js),Ldc,D(is,is),Ldd,E(js,js),Lde,      &
     &                     F(is,js),Ldf,scaloc,dsum,dscale,linfo)
               IF ( linfo>0 ) Info = linfo
               IF ( scaloc/=ONE ) THEN
                  DO k = 1 , js - 1
                     CALL ZSCAL(M,DCMPLX(scaloc,ZERO),C(1,k),1)
                     CALL ZSCAL(M,DCMPLX(scaloc,ZERO),F(1,k),1)
                  ENDDO
                  DO k = js , je
                     CALL ZSCAL(is-1,DCMPLX(scaloc,ZERO),C(1,k),1)
                     CALL ZSCAL(is-1,DCMPLX(scaloc,ZERO),F(1,k),1)
                  ENDDO
                  DO k = js , je
                     CALL ZSCAL(M-ie,DCMPLX(scaloc,ZERO),C(ie+1,k),1)
                     CALL ZSCAL(M-ie,DCMPLX(scaloc,ZERO),F(ie+1,k),1)
                  ENDDO
                  DO k = je + 1 , N
                     CALL ZSCAL(M,DCMPLX(scaloc,ZERO),C(1,k),1)
                     CALL ZSCAL(M,DCMPLX(scaloc,ZERO),F(1,k),1)
                  ENDDO
                  Scale = Scale*scaloc
               ENDIF
!
!              Substitute R(I,J) and L(I,J) into remaining equation.
!
               IF ( j>p+2 ) THEN
                  CALL ZGEMM('N','C',mb,js-1,nb,DCMPLX(ONE,ZERO),       &
     &                       C(is,js),Ldc,B(1,js),Ldb,DCMPLX(ONE,ZERO), &
     &                       F(is,1),Ldf)
                  CALL ZGEMM('N','C',mb,js-1,nb,DCMPLX(ONE,ZERO),       &
     &                       F(is,js),Ldf,E(1,js),Lde,DCMPLX(ONE,ZERO), &
     &                       F(is,1),Ldf)
               ENDIF
               IF ( i<p ) THEN
                  CALL ZGEMM('C','N',M-ie,nb,mb,DCMPLX(-ONE,ZERO),      &
     &                       A(is,ie+1),Lda,C(is,js),Ldc,               &
     &                       DCMPLX(ONE,ZERO),C(ie+1,js),Ldc)
                  CALL ZGEMM('C','N',M-ie,nb,mb,DCMPLX(-ONE,ZERO),      &
     &                       D(is,ie+1),Ldd,F(is,js),Ldf,               &
     &                       DCMPLX(ONE,ZERO),C(ie+1,js),Ldc)
               ENDIF
            ENDDO
         ENDDO
      ENDIF
!
      Work(1) = lwmin
!
!
!     End of ZTGSYL
!
      END SUBROUTINE ZTGSYL


C    @(#)nrpqv.f	20.3 2/13/96
        subroutine nrpqv (kt,pk,dpk,qk,dqk,vk)
C                computes the nodal injections, injection errors,
C                the nodal voltage, and V-limits for node KT.  It
C                does not modify any labeled commons.

      include 'ipfinc/parametr.inc'

      include 'ipfinc/alpha.inc'
c	Global variables used:
c		gkmu(r*8), bkmu(r*8), gkku(r*8), bkku(r*8),
c		ineti(r*8), inetr(r*8), pnetu(r*8), qnetu(r*8),
c		km, kmlen, ikmu
      include 'ipfinc/bus.inc'
c	Global variables used:
c		e(r*8), f(r*8)
c
      double precision   aik, bik, ek, fk, fm, em, gkm, bkm
C
        ek = e(kt)
        fk = f(kt)
        aik = 0.0d0
        bik = 0.0d0
        do 100 l = km(kt), km(kt)-1+kmlen(kt)
           mt = ikmu(l)
           fm = f(mt)
           em = e(mt)
           gkm = gkmu(l)
           bkm = bkmu(l)
           aik = aik + em*gkm - fm*bkm
           bik = bik + em*bkm + fm*gkm
  100   continue
        aik = aik +ek*gkku(kt) -fk*bkku(kt)
        bik = bik +ek*bkku(kt) +fk*gkku(kt)
        vk = dsqrt(ek**2 + fk**2)
        pk = aik*ek + bik*fk + inetr(kt)*vk
        qk = aik*fk - bik*ek - ineti(kt)*vk
        dpk = pnetu(kt) - pk
        dqk = qnetu(kt) - qk
        return
        end


Real Function dirct3(srt)
  Dimension arrayj(17), arrayl(17), arraym(17), arrayw(17), arrayb(17)
  Save
  Data arrayj/1.5, 0.5, 2.5, 2.5, 1.5, 0.5, 1.5, 3.5, 1.5, 0.5, 1.5, 0.5, 2.5, 0.5, 1.5, 2.5, 3.5/
  Data arrayl/2, 0, 2, 3, 2, 1, 1, 3, 1, 0, 2, 0, 3, 1, 1, 2, 3/
  Data arraym/1.52, 1.65, 1.675, 1.68, 1.70, 1.71, 1.72, 1.99, 1.60, 1.62, 1.70, 1.90, 1.905, 1.910, 1.86, 1.93, 1.95/
  Data arrayw/0.125, 0.15, 0.155, 0.125, 0.1, 0.11, 0.2, 0.29, 0.25, 0.16, 0.28, 0.15, 0.3, 0.22, 0.25, 0.25, 0.24/
  Data arrayb/0.55, 0.6, 0.375, 0.6, 0.1, 0.15, 0.15, 0.05, 0.35, 0.3, 0.15, 0.1, 0.1, 0.22, 0.2, 0.09, 0.4/
  pi = 3.1415926
  amn = 0.938
  amp = 0.138
  xs = 0
  branch = 1./3.
  Do ir = 1, 17
    If (ir>8) branch = 2./3.
    xs0 = fd1(arraym(ir), arrayj(ir), arrayl(ir), arrayw(ir), arrayb(ir), srt)
    xs = xs + 1.3*pi*branch*xs0*(0.1973)**2
  End Do
  dirct3 = xs
  Return
End Function dirct3


! mpiexec -np 4 bin/Debug/WGFM_test2.exe
program CFIE_test2
    use meshread_mod
    use EFIEDuffy_functions
    use MFIEDuffy_functions
    use EFIE_functions
    use linalg_mod
    use CFIE_mod
    use mpi
    implicit none

    real(8), parameter :: pi = 4d0 * atan(1d0)
    complex(8), parameter :: IU = (0d0, 1d0)

    real(8), parameter :: ep0 = 1d0 / (35950207149.4727056d0 * PI)  ! vacuum permittivity [F/m]
    real(8), parameter :: mu0 = PI * 4d-7                           ! vacuum permeability [H/m]

    real(8), parameter :: alpha1 = 0.5d0     ! CFIE first constant
    complex(8) :: alpha2                     ! CFIE second constant

    ! Variables
    type(Mesh) :: msh
    complex(8), allocatable :: Z1(:,:), Einc(:,:), V1(:)
    complex(8), allocatable :: Z2(:,:), Hinc(:,:), V2(:), EMat(:, :)
    complex(8), allocatable :: I1(:), I2(:), I3(:)
    integer :: j
    integer, parameter :: nNS = 6        ! number of quadrature points for EFIE
    integer, parameter :: nNS2 = 6        ! number of quadrature points for EFIE Sauter-Schwab

    ! MPI variables
    integer :: ierr, N_procs, id

    ! Parameters
    real(8) :: k        ! free-space wavenumber [1/m]
    real(8) :: w        ! angular frequency [rad/s]
    real(8) :: pol(3), src(3)
    character(len=100) :: file_msh

    k = 0.1d0                   ! free-space wavenumber [1/m]
    w = k / sqrt(ep0 * mu0)          ! angular frequency [rad/s]
    alpha2 = IU / k * (1 - alpha1)   ! CFIE second constant
    pol = [1.0d0, 1.0d0, 1.0d0]      ! polarization vector
    src = [-0.1d0, -0.1d0, -0.25d0]  ! location of dipole source
    file_msh = 'meshes/convergence_sphere/sph0400.msh' !sph0400

    ! MPI init
    call mpi_init(ierr)
    call mpi_comm_size(MPI_COMM_WORLD, N_procs, ierr)
    call mpi_comm_rank(MPI_COMM_WORLD, id, ierr)
    print *, "Total processes:", N_procs, "Process id:", id

    ! Load mesh
    call load_gmsh(file_msh, msh)

    ! Compute EFIE matrices
    if (id == 0) print *, "EFIE"
    !call genEFIESauterSchwabMat(Z1, msh, k, nNS, nNS2)
    call genEFIEDuffyMat(Z1, msh, k, nNS, nNS2)

    ! Compute MFIE matrices
    if (id == 0) print *, "MFIE"
    !call genMFIESauterSchwabMat(Z2, msh, k, EMat)
    call genMFIEMat(Z2, msh, k, EMat)

    ! Solve system
    if (id == 0) then
        allocate(V1(msh%nbEdg))
        allocate(I1(msh%nbEdg))
        allocate(V2(msh%nbEdg))
        allocate(I2(msh%nbEdg))
        allocate(I3(msh%nbEdg))

        ! Incident fields
        call DipoleFieldsOnMesh(pol, src, k, msh, Einc, Hinc)
        Hinc = Hinc / (IU * w * mu0)        ! adjust constants
!        allocate(Einc(1:msh%nbNod, 3))
!        allocate(Hinc(1:msh%nbNod, 3))
!        Einc = 0d0
!        Hinc = 0d0
!        do j = 1, msh%nbNod
!            Einc(j, 2) = exp(IU*k*msh%POS(j,1))  ! exp(ikx)
!            Hinc(j, 3) = Einc(j, 2) / sqrt(mu0 / ep0)
!        end do

        ! EFIE RHS
        V1 = -genRHS(Einc, msh)
        V1 = V1 / (IU * w * mu0)  ! adjust constants

        ! MFIE RHS
        V2 = -genRHSMFIE(Hinc, msh)
        Z2 = -0.5d0*Emat + Z2

        ! Solve
        call linsolve(I1, Z1, V1, msh%nbEdg) ! EFIE
        call linsolve(I2, Z2, V2, msh%nbEdg) ! MFIE
        call linsolve(I3, alpha1*Z1 + alpha2*Z2, alpha1*V1 + alpha2*V2, msh%nbEdg) ! CFIE
    end if

    ! Compute BEM solution and error
    if (id==0) then
        print *, 'msh ', file_msh
        print *, I1(5:15)/I2(5:15)
        print *, I1(5:15)/I3(5:15)
        print *, I2(5:15)/I3(5:15)
    end if

    call MPI_Finalize(ierr)
end program


! Module containing functions and subroutines for working with tensors in 9-voigt notation
! Convention used in these routines are the following
! Voigt 9 element notation [11, 22, 33, 12, 23, 13, 31, 21, 32]
! Voigt 6 element symmetric notation [11, 22, 33, 12, 23, 13]
! Thus                       |1 4 7|
! [1 2 3 4 5 6 7 8 9]   =>   |8 2 5|
!                            |6 9 3|
!
!==============================================================================
!        Summary of functions and subroutines contained in the module
!==============================================================================
!
! CONVERSIONS
! V6_2_V9           Transformation of a 2nd order tensor from 6 to 9 components in Voigt format
! V9_2_V6           Transformation of a 2nd order tensor from 9 to 6 components in Voigt format
! V9_2_M            Transformation of a 2nd order tensor with 9 components to matrix form of size(3,3)
! V6_2_M            Transformation of a 2nd order tensor with 6 components to matrix form of size(3,3)
! M_2_V9            Transformation of a matrix of size(3,3) to a second order tensor form with 9 components
! M_2_V6            Transformation of a matrix of size(3,3) to a second order tensor form with 9 components
! V9x9_2_V6x6       Transformation of a 4th order tensor of size(9,9) to size(6,6)
! V6x6_2_Sym_V9x9   Transformation of a 4th order tensor of size(6,6) to size(9,9)
! V9x9_2_T4         Transformation of a 4th order tensor of size(9,9) to pure tensor form of size(3,3,3,3)
! T4_2_V9x9         Transformation of a pure tensor form of size(3,3,3,3) to 4th order tensor of size(9,9)
! minsym_V9x9       Minor symmetric part of 9x9 4th order tensor, not implemented. Required for V9x9_2_V6x6, thus in this file
! majsym_V9x9       Major symmetric part of 9x9 4th order tensor, not implemented. Put in this file to correspond to minsym_V9x9
! ----------------------------------------------------------------------------------------------------------
!
! OPEN_PRODUCTS
! op_ve             Open product between two 1st order tensors (3 components) [i x j] giving matrix 3x3 out
! op_ve_9           Open product between two 1st order tensors (3 components) [i x j] giving 9 voigt out
! op_V9             Open product between two 2nd order tensors (9 components) [ij x kl]
! op_a_V9           Non-standard open product "above" between two 2nd order tensors (9 components) [ik x jl]
! op_b_V9           Non-standard open product "below" between two 2nd order tensors (9 components) [il x jk]
! Pop_V9            c_ijkl = 0.25*( a_ik b_jl+a_il b_jk+b_ik a_jl+b_il a_jk )
!
! Open products between 4th and - 2nd order tensors
! v9_op_v9x9        a_ij B_klmn - 2nd order in first position
! v9x9_op_v9        A_ijkl b_mn - 2nd order in last position
! v9_opc_v9x9       c_kl D_ijmn - 2nd order in center position
! ilmn_jk           c_ijklmn = a_ilmn * b_jk
! ikmn_jl           c_ijklmn = a_ikmn * b_jl
!
! 6-component functions
! op_V6             Open product between two 2nd order tensors (6 components)
! ----------------------------------------------------------------------------------------------------------
!
! CONTRACTIONS
! V9_d_v3           Contraction between 2nd order tensor and 1st order tensor
! V9_d_V9           Contraction between two 2nd order tensors with 9 components
! V9_dd_V9          Double contraction between two 2th order tensor of size (9)
! V9x9_dd_V9x9      Double contraction between two 4th order tensor of size (9,9)
! V9x9_dd_V9        Double contraction between a 4th order and a 2nd order tensor of size (9,9) and (9) respectively
! V9_dd_V9x9        Double contraction between a 2nd order and a 4th order tensor of size (9) and (9,9) respectively
!
! Special cases
! V9dV9dV9          Contraction between three 2nd order tensors with 9 components
! V9_d_V9x9         Single contraction between a 2nd and a 4th order tensor
! V9x9_d_V9         Single contraction between a 4th and a 2nd order tensor
!
! Operations on ordinary matrices
! M_x_ve            Multiplication between a matrix and vector
! ve_x_M            Multiplication between a vector and matrix
! ----------------------------------------------------------------------------------------------------------
!
! STANDARD_TENSORS (PROJECTION TENSORS)
! eye_V9            2nd order identity tensor (9 components)
! idev_v9x9         4th order deviatoric identity tensor
! ----------------------------------------------------------------------------------------------------------
!
! OPERATIONS
! trans_V9          Transpose of a 2nd order tensor with 9 components
! dev_V9            Deviatoric part of a 2nd order tensor with 9 components
! tr_V9             Trace of a 9 component voigt vector
! det_V9            Determinant of 2nd order 9-component tensor
! inv_V9            Inverse of 2nd order 9-component tensor
!
! Operations on full matrices
! det_M             Determinant of 1x1, 2x2 or 3x3 matrix
! inv_M3            Subroutine to calculate inverse of 3x3 matrix
! inv_M             Subroutine to calculate inverse of general matrix
! trans_M           Transpose of square matrix
! tr_M              Trace of a general square matrix
! norm_V3           Norm of a 1st order tensor with 3 components
! norm_V9           Norm of a general vector
! ----------------------------------------------------------------------------------------------------------
!
! STIFFNESS_CONVERSIONS
! dSdE_2_dPdF       Convert dSdE to dPdF
! dSdE_2_dtaudF     Convert dSdE to d(tau)dF
! dPdF_2_dtaudF     Convert dPdF to d(tau)dF
! ----------------------------------------------------------------------------------------------------------
!
! ABAQUS CONVERSIONS
!   Functions               Input           Description
! sigma_v9_2_sigma_abaqus   sigma_v9        Convert sigma in 9-voigt to abaqus sigma 6-voigt and abaqus index order
! sigma_abaqus_2_sigma_v9   sigma_abaqus    Convert sigma in abaqus sigma 6-voigt and abaqus index order to 9-voigt
! dtaudF_2_DDSDDE           dtaudF, F       Convert dtaudF in 9x9voigt to Abaqus DDSDDE in 6x6 voigt and abaqus index order
! ----------------------------------------------------------------------------------------------------------
!
! MISCELLANEOUS
! jacobi_mekh       ADD DESCRIPTION!
! eigsrt            ADD DESCRIPTION!
! M_pow             Calculate C^m where C is 3x3 matrix
! eig_prob          ADD DESCRIPTION!
! us_solve          ADD DESCRIPTION!
! us_gausjor        ADD DESCRIPTION!
!==============================================================================

include 'Tensors_module/Conversions.f90'       !Must always be included, required for multiple other modules
include 'Tensors_module/Open_products.f90'
include 'Tensors_module/Contractions.f90'
include 'Tensors_module/Standard_tensors.f90'
include 'Tensors_module/Operations.f90'
include 'Tensors_module/Stiffness_conversions.f90'
include 'Tensors_module/Abaqus_conversions.f90'
include 'Tensors_module/Miscellaneous.f90'

Module Tensors_module
use Conversions
use Open_products
use Contractions
use Standard_tensors
use Operations
use Stiffness_Conversions
use ABAQUS_Conversions
use Miscellaneous_tensors

Implicit none

END MODULE