      SUBROUTINE FTRNIM(DTA)
C
C THIS IS THE MAIN COMPUTATIONAL PROCEDURE FOR ONE SEMI-IMPLICIT TIME-
C STEP. THIS TIMESTEPPING IS DONE FOR THE PROGNOSTIC VARIABLES
C GEOPOTENTIAL, DIVERGENCE AND VORTICITY (SPECTRAL TRANSFORM
C ALGORITHM), USING A LEAPFROG TIMESTEPPING ALGORITHM.
C THE OLD TIMELEVEL IS LNM1, THE DERIVATIVE IS EVALUATED AT
C TIMELEVEL LN, AND THE COMPUTED VALUES GO INTO TIMELEVEL LNP1.
C THE NONLINEAR PRODUCTS ARE EVALUATED AT THE GRIDPOINTS, AND
C THE FORCING TERMS ARE ADDED FOR TEST CASE 4, USING
C THE ROUTINE FORCE TO OBTAIN THE GRID FORCING.
C A FFT TRANSFORM (FFT991) IS USED FOR EACH LATITUDE.
C THE NEW TIMELEVEL SPECTRAL COEFFICIENTS ARE COMPUTED BY THE
C ROUTINES
C VORTICITY: FTRNVE
C DIVERGENCE: FTRNDI
C GEOPOTENTIAL: FTRNPI
C
C CALLED BY: COMP1
C CALLS: FFT991, FORCE, FTRNDI, FTRNPI, FTRNVE,
C        GLAT, SHTRNS
C
C REVISIONS:
C 7-10-92 CHANGE TO CCM CODING CONVENTIONS (R. JAKOB)
C
C---- Model Parameters -------------------------------------------------
C
      INCLUDE 'params.i'
C
C---- Common Blocks ----------------------------------------------------
C
C TRANSFORM ARRAYS
      INCLUDE 'trnsfm.i'
C TIME DEPENDENT FIELDS
      INCLUDE 'tdvars.i'
C CONSTANTS & TIMESTEPS
      INCLUDE 'consts.i'
C WORKSPACE
      INCLUDE 'wrkspc.i'
C MOUNTAIN DATA FOR CASE 5
      INCLUDE 'finit.i'
C
C------------ Arguments ------------------------------------------------
C
C     Input
C
C TIMESTEP IN SECONDS
      REAL DTA
C
C------ Local Variables ------------------------------------------------
C
C     EQUIVALENCE TO STORAGE POOL IN COMMON BLOCK WRKSPC WHERE POSSIBLE
C
      REAL SIDNOM(0:KK), DDNOM(0:KK)
      EQUIVALENCE (SIDNOM(0),RVEC1(1)),(DDNOM(0),RVEC2(1))
C
      REAL TRMA(NLON+2,NLAT), TRMB(NLON+2,NLAT),
     $     TRMC(NLON+2,NLAT), TRMD(NLON+2,NLAT),
     $     TRME(NLON+2,NLAT), TRMF(NLON+2,NLAT),
     $     TRMG(NLON+2,NLAT), TRMH(NLON+2,NLAT)
      COMPLEX TRMAFC(NFC,NLAT), TRMBFC(NFC,NLAT),
     $        TRMCFC(NFC,NLAT), TRMDFC(NFC,NLAT),
     $        TRMEFC(NFC,NLAT), TRMFFC(NFC,NLAT),
     $        TRMGFC(NFC,NLAT), TRMHFC(NFC,NLAT)
      EQUIVALENCE (TRMA(1,1), TRMAFC(1,1), WS1(1,1)),
     $            (TRMB(1,1), TRMBFC(1,1), WS2(1,1)),
     $            (TRMC(1,1), TRMCFC(1,1), WS3(1,1)),
     $            (TRMD(1,1), TRMDFC(1,1), WS4(1,1)),
     $            (TRME(1,1), TRMEFC(1,1), WS5(1,1)),
     $            (TRMF(1,1), TRMFFC(1,1), WS6(1,1)),
     $            (TRMG(1,1), TRMGFC(1,1), WS7(1,1)),
     $            (TRMH(1,1), TRMHFC(1,1), WS8(1,1))
C
C     FORCING TERMS (PHYSICAL & SPECTRAL)
C
      REAL ETAFCG(NLON+2,NLAT), DIVFCG(NLON+2,NLAT),
     $     PHIFCG(NLON+2,NLAT)
C     COMPLEX EFSC(NALP), DFSC(NALP), PFSC(NALP)
C     EQUIVALENCE (EFSC(1),RMAT1(1)),
C    $            (DFSC(1),RMAT2(1)),
C    $            (PFSC(1),RMAT3(1))
C
C     TEMPORARIES
C
      REAL FAC,FAC1,RLAT
      INTEGER I,J,L,N,JN,JM,IS
      DIMENSION DIVTMP(MM+1),PHITMP(MM+1)
      COMPLEX DIVTMP,PHITMP
C
C----- External Functions ----------------------------------------------
C
C     GAUSSIAN LATITUDES
C
      REAL GLAT
      EXTERNAL GLAT
C
C----- Executable Statements -------------------------------------------
C
C     MAIN COMPUTATIONAL ROUTINE
C
C     ZERO TERMS FOR LATER ACCUMULATIONS
C
      DO 815 L=1,NALP
         ZETASC(L) = (0.0,0.0)
         DIVSC(L) = (0.0,0.0)
         PHISC(L) = (0.0,0.0)
  815 CONTINUE
C
C     COMPUTE THE FORCING TERMS (TEST CASE 4)
C
      IF (FORCED) THEN
         CALL FORCE(ETAFCG,DIVFCG,PHIFCG)
      ENDIF
C
C     EVALUATE NON-LINEAR PRODUCT TERMS
C     AND OLD TIMELEVEL OF VORTICITY, DIVERGENCE, GEOPOTENTIAL
C
      FAC1 = DTA/2.0*PHIBAR
      DO 20 J=1,NLAT
         RLAT = GLAT(J)
C
C        LATITUDE = RLAT
C
         FAC = 1.0/(2.0*COS(RLAT)**2)
         DO 10 I=1,NLON
            TRMA(I,J) = UCOS(I,J)*ZETA(I,J,LN)
            TRMB(I,J) = VCOS(I,J)*ZETA(I,J,LN)
            IF (FORCED .AND. MOMENT) THEN
               TRMA(I,J) = TRMA(I,J)-DIVFCG(I,J)
               TRMB(I,J) = TRMB(I,J)+ETAFCG(I,J)
            ENDIF
            TRMC(I,J) = UCOS(I,J)*PHI(I,J,LN)
            TRMD(I,J) = VCOS(I,J)*PHI(I,J,LN)
            TRME(I,J) = ZETA(I,J,LNM1)
            IF (FORCED .AND. (.NOT. MOMENT)) THEN
               TRME(I,J) = TRME(I,J)+DTA*ETAFCG(I,J)
            ENDIF
            TRMF(I,J) = (UCOS(I,J)**2+VCOS(I,J)**2)*FAC
     $                + PHI(I,J,LNM1)/2.0
            IF (FTOPO) THEN
               TRMF(I,J) = TRMF(I,J) + GRAV*MOUNT(I,J)
            ENDIF
C
C           DIVERGENCE (OLD TIME LEVEL & FORCING)
C
            TRMG(I,J) = DIV(I,J,LNM1)
            IF (FORCED .AND. (.NOT. MOMENT)) THEN
               TRMG(I,J) = TRMG(I,J) + DTA*DIVFCG(I,J)
            ENDIF
C
C           GEOPOTENTIAL (OLD TIME LEVEL & FORCING)
C
            TRMH(I,J) = PHI(I,J,LNM1)
     $                - FAC1*DIV(I,J,LNM1)
            IF (FORCED) THEN
               TRMH(I,J) = TRMH(I,J) + DTA*PHIFCG(I,J)
            ENDIF
   10    CONTINUE
   20 CONTINUE
C
C     FOURIER TRANSFORM NON-LINEAR TERMS IN PLACE
C
      CALL FFT991(TRMA,FFTWS2,TRIGS,IFAX,1,NLON+2,NLON,NLAT,-1)
      CALL FFT991(TRMB,FFTWS2,TRIGS,IFAX,1,NLON+2,NLON,NLAT,-1)
      CALL FFT991(TRMC,FFTWS2,TRIGS,IFAX,1,NLON+2,NLON,NLAT,-1)
      CALL FFT991(TRMD,FFTWS2,TRIGS,IFAX,1,NLON+2,NLON,NLAT,-1)
      CALL FFT991(TRME,FFTWS2,TRIGS,IFAX,1,NLON+2,NLON,NLAT,-1)
      CALL FFT991(TRMF,FFTWS2,TRIGS,IFAX,1,NLON+2,NLON,NLAT,-1)
      CALL FFT991(TRMG,FFTWS2,TRIGS,IFAX,1,NLON+2,NLON,NLAT,-1)
      CALL FFT991(TRMH,FFTWS2,TRIGS,IFAX,1,NLON+2,NLON,NLAT,-1)
C
C     FWD LEGENDRE TRANSFORM & UPDATE OF VORTICITY SPECTRAL COEFFICIENTS
C
      CALL FTRNVE (DTA, TRMAFC, TRMBFC, TRMEFC, ZETASC)
C
C     DIVERGENCE TIMESTEPPING (SPECTRAL CODE)
C
      CALL FTRNDI (DTA, TRMAFC, TRMBFC, TRMFFC, TRMGFC, DIVSC)
C
C     GEOPOTENTIAL TIMESTEPPING (SPECTRAL CODE)
C
      CALL FTRNPI (DTA, TRMCFC, TRMDFC, TRMHFC, PHISC)
C
C     UPDATE DIVERGENCE AND MASS CONTINUITY SPECTRAL COEFFICIENTS
C     FOR SEMI-IMPLICIT TIMESTEPPING (SEE H. RITCHIE'S PAPER)
C
      FAC = DTA/2.0*PHIBAR
      FAC1 = 0.25*PHIBAR*DTA**2
      DO 730 N=0,KK
         SIDNOM(N) = 1.0/(1.0 + FAC1*A2NNP1(N))
         DDNOM(N) = DTA/2.0*A2NNP1(N)
  730 CONTINUE
C
      DO 775 JN=0,NN
         IS = LDIAG(JN,2)
C
         DO 760 JM=1,LDIAG(JN,1)
            N = JM + JN - 1
            DIVTMP(JM) = DIVSC(IS+JM)
            PHITMP(JM) = SIDNOM(N)
     $                 * (PHISC(IS+JM) - FAC * DIVTMP(JM))
            DIVSC(IS+JM) = DDNOM(N) * PHITMP(JM)
     $                   + DIVTMP(JM)
            PHISC(IS+JM) = PHITMP(JM)
  760    CONTINUE
  775 CONTINUE
C
      RETURN
C
      END


subroutine matove(xmatr,vecto,ndime,ntens)
!**********************************************************************
!
!**** This routine stores a symmetric matrix XMATR into a vector VECTO
!
!**********************************************************************
  use      typre
  implicit none
  integer(ip),intent(in)   :: ndime,ntens
  real(rp),intent(in)      ::xmatr(ndime,ndime)
  real(rp),intent(out)     ::vecto(ntens)

      if(ndime.eq.2) then
        vecto(1)=xmatr(1,1)
        vecto(3)=xmatr(1,2)
        vecto(2)=xmatr(2,2)
      else
        vecto(1)=xmatr(1,1)
        vecto(4)=xmatr(1,2)
        vecto(2)=xmatr(2,2)
        vecto(5)=xmatr(1,3)
        vecto(6)=xmatr(2,3)
        vecto(3)=xmatr(3,3)
      end if

end subroutine matove


      PROGRAM DRDJACG2
c>> 2009-10-28 DRDJACG2 Krogh -- Remove implicit none.
c>> 2009-10-26 DRDJACG2 Krogh -- *'s used for dims for NAG compiler.
c>> 2008-11-01 DRDJACG2 Hanson -- Added row dim parameters to evaluators
c>> 2006-12-19 DRDJACG2 Hanson -- Added tot. energy constraint in 3rd ex
c>> 2006-04-11 DRDJACG1 Hanson -- Reduced lengths of djacg work arrays.
c>> 2006-04-09 DRDJACG2  Krogh Fixed dimension of YSCALE.
c>> 2003-07-08 DRDJACG2  R. J. Hanson Fix accum. option with djacg().
c>> 2002-02-01 DRDJACG2  R. J. Hanson Example 2 Code, with Download

C     Solve a planar pendulum problem in rectangular coordinates.
C     The equation is transformed from "Index 3" to "Index 1"
C     by differentiating the length constraint twice.  The system
C     is integrated (using DDASSFC) using these two constraints.
C     In the second integration the problem is transformed from
C     "Index 3" to "Index 0" by differentiating the length constraint
C     three times.  The routine DDASSFD uses these three constraints.
C     A total energy constraint is added in routine DDASSFE.
C     This example shows that the constraints remain satisfied,
C     and the integration can succeed with either approach.
C     It is more efficient to use the "Index 0" problem than
C     the "Index 1" problem.

C     (THIS VERSION USES NUMERICAL DIFFERENTIATION FOR THE PARTIALS
C     NEEDED IN ?DASLX, EXAMPLE 5, AVAILABLE WITH DOWNLOAD.)
c--D replaces "?": DR?JACG2,?DASLX,?DASSFC,?DASSFD,?DASSFE,?COPY,?JACG

      EXTERNAL DDASSFC, DDASSFD, DDASSFE

      integer NDIG, NEQ, MAXCON, LRW, LIW
C     Set number of equations:
      parameter (NEQ = 5)
C     Set number of constraints.
      parameter (MAXCON = 4)
C     Work space sizes:
      parameter (LIW = 30 + NEQ)
      parameter (LRW =  45 + (5 + 2*MAXCON + 4) * NEQ + NEQ**2)
      double precision TOL
c++S Default NDIG = 4
c++  Default NDIG = 11
c++ Substitute for NDIG below
      parameter (NDIG = 11)
      parameter (TOL = 10.D0 **(-NDIG))

      INTEGER I, INFO(16), IDID, IWORK(LIW)
      DOUBLE PRECISION T, Y(5), YPRIME(5), TOUT,
     +  RTOL(5), ATOL(5), RWORK(LRW), LENGTH,
     +  DRL, DRV
      LOGICAL CONSTRAINT
      INTEGER KR, KF, KC
      common / COUNTS / KR, KF, KC

  100 format(20x,
     +'Example Results for a Constrained Pendulum Problem, Index 1')
  105 format(20x,'(Numerical Partials)')
  106 format(20x,'(Numerical Partials and Total Energy Constrained)')
  110 format(/8x,'T',12x,'y_1',11x,'y_2',11x,
     + 'y_3',11x,'y_4',11x,'y_5'/ 1P,6D14.4/)
  130 format(6x,'At the time value', F10.2, 2x,
     + 'the integration was stopped.')
  140 format(
     +'The pendulum length or variation has large weighted errors.'/
     +'These should remain less than 1 is magnitude:',
     + 10x,2F8.2/)
  150 format(6x,
     +'The pendulum length and its variation have small errors.'//)
  160 format(20x,
     +'Example Results for a Constrained Pendulum Problem, Index 0')
  170 format(5x,'No. of Residual Evaluations',6x,
     + 'Factorizations',6x,'No. of User Solves'/
     + 'Constraint Partials-',1x,I8,12x,I8,17x,I8/)

C     Tolerances:
      DO 10 I=1,NEQ
        ATOL(I)=TOL
        RTOL(I)=TOL
   10 CONTINUE
C     Setup options:
      DO 20 I=1,16
        INFO(I)=0
   20 CONTINUE
C     Use partial derivatives provided in evaluation routine:
      INFO(5)=2
C     Constrain solution, with 2 constraints:
      INFO(10)=2
C     Allow for more 10 * steps (than default):
      INFO(12)=50000
C     This is the pendulum length.
      LENGTH=1.1D0
      DO 30 I=1,1000,10
C     Integrate from T=I-1 to TOUT=T+1.  Final TOUT=10.
C     When the solution first drifts away from the constraints, stop.
        T=dble(I-1)
        TOUT=T+10.D0
        CALL DDASLX (DDASSFC, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL,
     +    ATOL, IDID, RWORK, LRW, IWORK, LIW)
C  Compute residuals on length and its variation.  They
C  should be smaller than the tolerances used.
        DRL=(Y(1)**2+Y(2)**2-LENGTH**2)/(RTOL(1)*LENGTH**2+ATOL(1))
        DRV=(Y(1)*Y(3)+Y(2)*Y(4))/(RTOL(1)*(abs(Y(1)*Y(3))+
     +   abs(Y(1)*Y(4)))+ATOL(1))
        CONSTRAINT=ABS(DRL) .le. 1.D0 .and. ABS(DRV) .le. 1.D0
        IF(.not. CONSTRAINT) GO TO 40
   30 CONTINUE
   40 CONTINUE

      write(*,100)
      write(*,105)
      write(*,110) TOUT, Y
      write(*,170) KR, KF, KC
      write(*,130) TOUT
      IF(.not. CONSTRAINT) THEN
        write(*,140) DRL, DRV
      ELSE
        write(*,150)
      END IF

C     Start the integration over for the index 0 problem.
      INFO(1)=0
C     Set the number of constraints to 3.
      INFO(10)=3
      DO 50 I=1,1000,10
C     Integrate from T=I-1 to TOUT=T+1.
        T=dble(I-1)
        TOUT=T+10.D0
        CALL DDASLX (DDASSFD, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL,
     +    ATOL, IDID, RWORK, LRW, IWORK, LIW)

C  Compute residuals on length and its variation.  They
C  should be smaller than the tolerances used.
        DRL=(Y(1)**2+Y(2)**2-LENGTH**2)/(RTOL(1)*LENGTH**2+ATOL(1))
        DRV=(Y(1)*Y(3)+Y(2)*Y(4))/(RTOL(1)*(abs(Y(1)*Y(3))+
     +   abs(Y(1)*Y(4)))+ATOL(1))
        CONSTRAINT=ABS(DRL) .le. 1.D0 .and. ABS(DRV) .le. 1.D0
        IF(.not. CONSTRAINT) GO TO 60
   50 CONTINUE
   60 CONTINUE
      write(*,160)
      write(*,105)
      write(*,110) TOUT, Y
      write(*,170) KR, KF, KC
      write(*,130) TOUT
      IF(.not. CONSTRAINT) THEN
        write(*,140) DRL, DRV
      ELSE
        write(*,150)
      END IF
C     Start the integration over for the index 0 problem.
      INFO(1)=0
C     Set the number of constraints to 4.
C     (This includes constant total energy).
      INFO(10)=4
      DO 70 I=1,1000,10
C     Integrate from T=I-1 to TOUT=T+1.
        T=dble(I-1)
        TOUT=T+10.D0
        CALL DDASLX (DDASSFE, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL,
     +    ATOL, IDID, RWORK, LRW, IWORK, LIW)

C  Compute residuals on length and its variation.  They
C  should be smaller than the tolerances used.
        DRL=(Y(1)**2+Y(2)**2-LENGTH**2)/(RTOL(1)*LENGTH**2+ATOL(1))
        DRV=(Y(1)*Y(3)+Y(2)*Y(4))/(RTOL(1)*(abs(Y(1)*Y(3))+
     +   abs(Y(1)*Y(4)))+ATOL(1))
        CONSTRAINT=ABS(DRL) .le. 1.D0 .and. ABS(DRV) .le. 1.D0
        IF(.not. CONSTRAINT) GO TO 80
   70 CONTINUE
   80 CONTINUE
      write(*,160)
      write(*,106)
      write(*,110) TOUT, Y
      write(*,170) KR, KF, KC
      write(*,130) TOUT
      IF(.not. CONSTRAINT) THEN
        write(*,140) DRL, DRV
      ELSE
        write(*,150)
      END IF
      END

      SUBROUTINE DDASSFC(T,Y,YPRIME,DELTA,D,LDD,CJ,IRES,RWORK,IWORK)
C     Routine for the swinging simple pendulum problem,
C     with constraints on the index 2 and 3 equations.
      DOUBLE PRECISION T, Y(*), YPRIME(*), DELTA(*), D(LDD,*),
     +  CJ, RWORK(*), LSQ, MG
      INTEGER IRES, IWORK(*),LDD

      DOUBLE PRECISION ONE, TWO, ZERO, MASS, LENGTH, GRAVITY

C     Use numerical derivatives but based on calls to DJACG.
      INTEGER MODE, IOPT(5), IWK(21)
      DOUBLE PRECISION WK(3*5+18), F(5), FACC(5),
     .  FACJ(5), YSCALE(5)

      PARAMETER (ONE=1.D0, TWO=2.D0,
     +  ZERO=0.D0, MASS=1.D0, LENGTH=1.1D0, GRAVITY=9.806650D0)
      SAVE mg, LSQ, FACC, FACJ, IOPT, YSCALE
      INTEGER KR, KF, KC
      common / COUNTS / KR, KF, KC
C This is the setup call.  YPRIME need not be solved for as we
C are providing the correct initial values.
      IF(IRES .EQ. 0) THEN
        mg=mass*gravity
        LSQ=length**2
        Y(1)=LENGTH
        Y(2)=ZERO
        Y(3)=ZERO
        Y(4)=ZERO
        Y(5)=ZERO

        YPRIME(1)=ZERO
        YPRIME(2)=ZERO
        YPRIME(3)=ZERO
        YPRIME(4)=-GRAVITY
        YPRIME(5)=ZERO

        KR=0
        KF=0
        KC=0
C Initialize things needed for numerical differentiation.
        FACC(1)=ZERO
        FACJ(1)=ZERO
      END IF

C The sytem residual value.

      IF(IRES .EQ. 1) THEN
        DELTA(1)= Y(3)-YPRIME(1)
        DELTA(2)= Y(4)-YPRIME(2)
        DELTA(3)=-Y(1)*Y(5)-mass*YPRIME(3)
        DELTA(4)=-Y(2)*Y(5)-mass*YPRIME(4)-mg
        DELTA(5)= mass*(Y(3)**2+Y(4)**2)-mg*Y(2)-LSQ*Y(5)
C Count residual evaluations.
        KR=KR+1
      END IF

C The partial derivative matrix.
      IF(IRES .EQ. 2) THEN
        MODE=0
C Accumulate all but one partial derivative columns.

C Set to accumulate variables 1-4:
        IOPT(1)=-3
        IOPT(2)= 4
C Shift to using one-sided differences.
        IOPT(3)=-1
C Use on all remaining variables: number 5.
        IOPT(4)= 0
        YSCALE(1)=ZERO
C Pre-compute partials wrt y'.  These values are accumulated.
        D(1,1)=-CJ
        D(2,2)=-CJ
        D(3,3)=-mass*CJ
        D(4,4)=D(3,3)
   10 CONTINUE
C The value of f(y) is normally returned in WK(1:5).
C Note that all but one partial with respect to y' have been
C analytically pre-computed and so the results are accumulated.
        WK(1)=Y(3)
        WK(2)=Y(4)
        WK(3)=-Y(1)*Y(5)
        WK(4)=-Y(2)*Y(5)
        WK(5)= mass*(Y(3)**2+Y(4)**2)-mg*Y(2)-LSQ*Y(5)
C Compute f(y) and make a special copy step for the
C  evaluation point.
        IF(MODE .eq. 0) THEN
          F(1)=WK(1)
          F(2)=WK(2)
          F(3)=WK(3)
          F(4)=WK(4)
          F(5)=WK(5)
          FACJ(1)=ZERO
        END IF
C This is a Math a la Carte code for numerical derivatives.
        CALL DJACG (MODE, 5, 5, Y,
     .              F, D, LDD, YSCALE,
     .              FACJ, IOPT, WK, 33, IWK, 21)
        IF(MODE .gt. 0) GO TO 10
        IF(MODE .lt. 0) THEN
            PRINT
     1      '('' DDASSFC: Initial error in argument number '',I2)',-MODE
            STOP '1'
          END IF
C All system partials are computed.  Count an evaluation.
        KF=KF+1
      END IF

C The constraining equations after the corrector has converged.
C Both partials and residuals are required.
      IF(IRES .EQ. 5) THEN
        MODE=0
C In this use of numerical differentiation, no special treatment
C is required for the variables.  The rest of IOPT(:) stays intact.
        IOPT(1)=0
        YSCALE(1)=ZERO
   20 CONTINUE
C The value of f(y) is normally returned in WK(1:2).
        WK(1)=Y(1)**2+Y(2)**2-LSQ
        WK(2)=Y(1)*Y(3)+Y(2)*Y(4)
C Compute f(y) and make a special copy step for the point in question.
        IF(MODE .eq. 0) THEN
          DELTA(6)=WK(1)
          DELTA(7)=WK(2)
          FACC(1)=ZERO
        END IF
C This is a Math a la Carte code for numerical derivatives.
        CALL DJACG (MODE, 2, 5, Y,
     .              DELTA(6), D(6,1), LDD, YSCALE,
     .              FACC, IOPT, WK, 33, IWK, 21)
        IF(MODE .gt. 0) GO TO 20

        IF(MODE .lt. 0) THEN
            PRINT
     1      '('' DDASSFC: Initial error in argument number '',I2)',-MODE
            STOP '2'
          END IF
C All constraint partials are computed.  Count an evaluation.
        KC=KC+1
      END IF
      END

      SUBROUTINE DDASSFD(T,Y,YPRIME,DELTA,P,LDP,CJ,IRES,RWORK,IWORK)
C
C     Routine for the swinging simple pendulum problem,
C     with constraints on the index 1,2 amd 3 equations.
C     Use P(:,:) to distinguish from D(:,:) in routine DDASSFC.
      INTEGER IRES, IWORK(*), LDP
      DOUBLE PRECISION T, Y(*), YPRIME(*), DELTA(*), P(LDP,*),
     +  CJ, RWORK(*), LSQ, MG
C     Use numerical derivatives but based on calls to DJACG.
      INTEGER MODE, IOPT(2), IWK(21)
      DOUBLE PRECISION WK(3*5+18), F(5), FACC(5),
     .  FACJ(5), YSCALE(5)

      DOUBLE PRECISION ONE, TWO, THREE, ZERO, MASS, LENGTH, GRAVITY
      PARAMETER (ONE=1.D0, TWO=2.D0, THREE=3.D0,
     +  ZERO=0.D0, MASS=1.D0, LENGTH=1.1D0, GRAVITY=9.806650D0)
      SAVE mg, LSQ, FACC, FACJ, YSCALE, IOPT
      INTEGER KR, KF, KC
      common / COUNTS / KR, KF, KC
C This is the setup call.
      IF(IRES .EQ. 0) THEN
        mg=mass*gravity
        LSQ=length**2
        Y(1)=LENGTH
        Y(2)=ZERO
        Y(3)=ZERO
        Y(4)=ZERO
        Y(5)=ZERO
        YPRIME(1)=ZERO
        CALL DCOPY(5,YPRIME,0,YPRIME,1)
        yprime(4)=-gravity
        KR=0
        KF=0
        KC=0
        YSCALE(1)=ZERO
      END IF

C The sytem residual value.
      IF(IRES .EQ. 1) THEN
        DELTA(1)=Y(3)-YPRIME(1)
        DELTA(2)=Y(4)-YPRIME(2)
        DELTA(3)=-Y(1)*Y(5)-mass*YPRIME(3)
        DELTA(4)=-Y(2)*Y(5)-mass*YPRIME(4)-mg
        DELTA(5)= -THREE*mg*Y(4) -LSQ*YPRIME(5)
        KR=KR+1
      END IF

C The partial derivative matrix.
      IF(IRES .EQ. 2) THEN
        MODE=0
        IOPT(1)=0
C This is the last column number to be accumulated when
C doing numerical differentiation.
        IOPT(2)= 5

   10 CONTINUE
C The value of f(y) is normally returned in WK(1:5).
C Note that the partials with respect to y' have been
C analytically pre-computed and so the results are accumulated.
        WK(1)=Y(3)
        WK(2)=Y(4)
        WK(3)=-Y(1)*Y(5)
        WK(4)=-Y(2)*Y(5)
        WK(5)= -THREE*mg*Y(4)
C Compute f(y) and make a special copy step for the point in question.
        IF(MODE .eq. 0) THEN
          F(1)=WK(1)
          F(2)=WK(2)
          F(3)=WK(3)
          F(4)=WK(4)
          F(5)=WK(5)
          FACJ(1)=ZERO
        END IF
C This is a Math a la Carte code for numerical derivatives.
        CALL DJACG (MODE, 5, 5, Y,
     .              F, P, LDP, YSCALE,
     .              FACJ, IOPT, WK, 33, IWK, 21)
        IF(MODE .gt. 0) GO TO 10
        IF(MODE .lt. 0) THEN
            PRINT
     1     '('' DDASSFD: Initial error in argument number '',I2)', -MODE
            STOP '1'
          END IF
C All system partials are computed.  Count an evaluation.
        KF=KF+1
C This part of the derivative matrix is a diagonal, hence
C easy to compute.
        P(1,1)=-CJ+P(1,1)
        P(2,2)=-CJ+P(2,2)
        P(3,3)=-mass*CJ+P(3,3)
        P(4,4)=P(3,3)
        P(5,5)=-LSQ*CJ+P(5,5)

      END IF

C The constraining equations after the corrector has converged.
C Both partials and residuals are required.
      IF(IRES .EQ. 5) THEN
        MODE=0
        IOPT(1)=0
        YSCALE(1)=ZERO
   20 CONTINUE
C The value of f(y) is normally returned in WK(1:3).
        WK(1)=Y(1)**2+Y(2)**2-LSQ
        WK(2)=Y(1)*Y(3)+Y(2)*Y(4)
        WK(3)=MASS*(Y(3)**2+Y(4)**2)-MG*Y(2)-LSQ*Y(5)
C Compute f(y) and make a special copy step for the
C evaluation point.
        IF(MODE .eq. 0) THEN
          DELTA(6)=WK(1)
          DELTA(7)=WK(2)
          DELTA(8)=WK(3)
          FACC(1)=ZERO
        END IF
C This is a Math a la Carte code for numerical derivatives.
        CALL DJACG (MODE, 3, 5, Y,
     .              DELTA(6), P(6,1), LDP, YSCALE,
     .              FACC, IOPT, WK, 33, IWK, 21)
        IF(MODE .gt. 0) GO TO 20
        IF(MODE .lt. 0) THEN
            PRINT
     1      '('' DDASSFD: Initial error in argument number '',I2)',-MODE
            STOP '2'
          END IF
C All constraint partials are computed.  Count an evaluation.
        KC=KC+1
      END IF
      END

      SUBROUTINE DDASSFE(T,Y,YPRIME,DELTA,P,LDP,CJ,IRES,RWORK,IWORK)
C
C     Routine for the swinging simple pendulum problem,
C     with constraints on the index 1,2 amd 3 equations.
C     Also the constant energy constraint is added.
C     Use P(:,:) to distinguish from D(:,:) in routine DDASSFC.
      INTEGER IRES, IWORK(*), LDP
      DOUBLE PRECISION T, Y(*), YPRIME(*), DELTA(*), P(LDP,*),
     +  CJ, RWORK(*)
C     Use numerical derivatives but based on calls to DJACG.
      INTEGER MODE, IOPT(2), IWK(21)
      DOUBLE PRECISION WK(43), F(5), FACC(5),
     .  FACJ(5), YSCALE(1)

      DOUBLE PRECISION HALF, ONE, TWO, THREE, ZERO, MASS, LENGTH,
     +                 GRAVITY, LSQ, MG
      PARAMETER (ONE=1.D0, TWO=2.D0, THREE=3.D0, HALF=0.5D0,
     +  ZERO=0.D0, MASS=1.D0, LENGTH=1.1D0, GRAVITY=9.806650D0,
     +          mg=mass*gravity, LSQ=length**2)
c      SAVE FACC, FACJ, YSCALE, IOPT
      INTEGER KR, KF, KC
      common / COUNTS / KR, KF, KC
C This is the setup call.
      IF(IRES .EQ. 0) THEN
        Y(1)=LENGTH
        Y(2)=ZERO
        Y(3)=ZERO
        Y(4)=ZERO
        Y(5)=ZERO
        YPRIME(1)=ZERO
        YPRIME(2)=ZERO
        YPRIME(3)=ZERO
        YPRIME(5)=ZERO
        YPRIME(4)=-GRAVITY
        KR=0
        KF=0
        KC=0
        YSCALE(1)=ZERO
      END IF

C The sytem residual value.
      IF(IRES .EQ. 1) THEN
        DELTA(1)=Y(3)-YPRIME(1)
        DELTA(2)=Y(4)-YPRIME(2)
        DELTA(3)=-Y(1)*Y(5)-mass*YPRIME(3)
        DELTA(4)=-Y(2)*Y(5)-mass*YPRIME(4)-mg
        DELTA(5)= -THREE*mg*Y(4) -LSQ*YPRIME(5)
        KR=KR+1
      END IF

C The partial derivative matrix.
      IF(IRES .EQ. 2) THEN
        MODE=0
C Accumulate all partial derivative columns.
C Pre-compute partials wrt y' and accumulate results.
        IOPT(1)=-3
C This is the last column number to be accumulated when
C doing numerical differentiation.
        IOPT(2)= 5

C This part of the derivative matrix is a diagonal, hence
C easy to compute.
        P(1,1)=-CJ
        P(2,2)=-CJ
        P(3,3)=-mass*CJ
        P(4,4)=P(3,3)
        P(5,5)=-LSQ*CJ
   10 CONTINUE
C The value of f(y) is normally returned in WK(1:5).
C Note that the partials with respect to y' have been
C analytically pre-computed and the results are accumulated.
        WK(1)=Y(3)
        WK(2)=Y(4)
        WK(3)=-Y(1)*Y(5)
        WK(4)=-Y(2)*Y(5)
        WK(5)=-THREE*mg*Y(4)
C Compute f(y) and make a special copy step for the point in question.
        IF(MODE .eq. 0) THEN
          F(1)=WK(1)
          F(2)=WK(2)
          F(3)=WK(3)
          F(4)=WK(4)
          F(5)=WK(5)
          FACJ(1)=ZERO
          YSCALE(1)=ZERO
        END IF
C This is a Math a la Carte code for numerical derivatives.
        CALL DJACG (MODE, 5, 5, Y,
     .              F, P, LDP, YSCALE,
     .              FACJ, IOPT, WK, 43, IWK, 21)
        IF(MODE .gt. 0) GO TO 10
        IF(MODE .lt. 0) THEN
            PRINT
     1     '('' DDASSFD: Initial error in argument number '',I2)', -MODE
            STOP '1'
          END IF
C All system partials are computed.  Count an evaluation.
        KF=KF+1
      END IF

C The constraining equations after the corrector has converged.
C Both partials and residuals are required.
      IF(IRES .EQ. 5) THEN
        MODE=0
        IOPT(1)=0
        FACC(1)=ZERO
        YSCALE(1)=ZERO
   20 CONTINUE
C The value of f(y) is normally returned in WK(1:3).
        WK(1)=Y(1)**2+Y(2)**2-LSQ
        WK(2)=Y(1)*Y(3)+Y(2)*Y(4)
        WK(3)=MASS*(Y(3)**2+Y(4)**2)-MG*Y(2)-LSQ*Y(5)
C This constraint is constant total energy.
        WK(4)=HALF*MASS*(Y(3)**2+Y(4)**2)+MG*Y(2)

C Compute f(y) and make a special copy step for the
C evaluation point.
        IF(MODE .eq. 0) THEN
          DELTA(6)=WK(1)
          DELTA(7)=WK(2)
          DELTA(8)=WK(3)
          DELTA(9)=WK(4)
          F(1)=WK(1)
          F(2)=WK(2)
          F(3)=WK(3)
          F(4)=WK(4)
        END IF
C This is a Math a la Carte code for numerical derivatives.
        CALL DJACG (MODE, 4, 5, Y,
     .              F, P(6,1), LDP, YSCALE,
     .              FACC, IOPT, WK, 43, IWK, 21)
        IF(MODE .gt. 0) GO TO 20
        IF(MODE .lt. 0) THEN
            PRINT
     1      '('' DDASSFE: Initial error in argument number '',I2)',-MODE
            STOP '2'
          END IF
C All constraint partials are computed.  Count an evaluation.
         KC=KC+1
      END IF
      END


*> \brief \b SCNRM2
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       REAL FUNCTION SCNRM2(N,X,INCX)
*
*       .. Scalar Arguments ..
*       INTEGER INCX,N
*       ..
*       .. Array Arguments ..
*       COMPLEX X(*)
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SCNRM2 returns the euclidean norm of a vector via the function
*> name, so that
*>
*>    SCNRM2 := sqrt( x**H*x )
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup single_blas_level1
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  -- This version written on 25-October-1982.
*>     Modified on 14-October-1993 to inline the call to CLASSQ.
*>     Sven Hammarling, Nag Ltd.
*> \endverbatim
*>
*  =====================================================================
      REAL FUNCTION SCNRM2(N,X,INCX)
*
*  -- Reference BLAS level1 routine (version 3.4.0) --
*  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      INTEGER INCX,N
*     ..
*     .. Array Arguments ..
      COMPLEX X(*)
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL ONE,ZERO
      PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
*     ..
*     .. Local Scalars ..
      REAL NORM,SCALE,SSQ,TEMP
      INTEGER IX
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC ABS,AIMAG,REAL,SQRT
*     ..
      IF (N.LT.1 .OR. INCX.LT.1) THEN
          NORM = ZERO
      ELSE
          SCALE = ZERO
          SSQ = ONE
*        The following loop is equivalent to this call to the LAPACK
*        auxiliary routine:
*        CALL CLASSQ( N, X, INCX, SCALE, SSQ )
*
          DO 10 IX = 1,1 + (N-1)*INCX,INCX
              IF (REAL(X(IX)).NE.ZERO) THEN
                  TEMP = ABS(REAL(X(IX)))
                  IF (SCALE.LT.TEMP) THEN
                      SSQ = ONE + SSQ* (SCALE/TEMP)**2
                      SCALE = TEMP
                  ELSE
                      SSQ = SSQ + (TEMP/SCALE)**2
                  END IF
              END IF
              IF (AIMAG(X(IX)).NE.ZERO) THEN
                  TEMP = ABS(AIMAG(X(IX)))
                  IF (SCALE.LT.TEMP) THEN
                      SSQ = ONE + SSQ* (SCALE/TEMP)**2
                      SCALE = TEMP
                  ELSE
                      SSQ = SSQ + (TEMP/SCALE)**2
                  END IF
              END IF
   10     CONTINUE
          NORM = SCALE*SQRT(SSQ)
      END IF
*
      SCNRM2 = NORM
      RETURN
*
*     End of SCNRM2.
*
      END
c $Id$


module divide
use evaluate
use modify
implicit none

private
public :: split_bezier_curve, extract_bezier_curve, split_bezier_surface
public :: split_curve, split_surface

contains

subroutine split_bezier_curve(cpw, n, u, a, b, qw1, a1, b1, qw2, a2, b2)
    !> Split Bezier curve into two segments.
    !> cpw - Control points.
    !> n - Number of control points - 1.
    !> u - Parameter to split curve at (0 <= u <= 1).
    !> a - Lower domain of curve (0 <= a < b).
    !> b - Upper domain of curve (a < b <= 1).
    !> qw1 - Control points for curve 1.
    !> a1 - Lower domain for curve 1.
    !> b1 - Upper domain for curve 1.
    !> qw2 - Control points for curve 2.
    !> a2 - Lower domain for curve 2.
    !> b2 - Upper domain for curve 2.

    !f2py intent(in) cpw, n, u, a, b
    !f2py intent(out) qw1, a1, b1, qw2, a2, b2
    !f2py depend(n) cpw, qw1, qw2

    ! Input
    integer, intent(in) :: n
    double precision, intent(in) :: u, a, b
    double precision, intent(in) :: cpw(0:n,0:3)

    ! Output
    double precision, intent(out) :: a1, b1, a2, b2
    double precision, intent(out) :: qw1(0:n, 0:3), qw2(0:n, 0:3)

    ! Working
    integer :: k, i

    qw1(:, :) = 0.0d0
    qw2(:, :) = 0.0d0

    ! New control points.
    qw2 = cpw
    qw1(0, :) = qw2(0, :)
    do k = 1, n
        do i = 0, n - k
            qw2(i, :) = (1.d0 - u) * qw2(i, :) + u * qw2(i + 1, :)
            qw1(k, :) = qw2(0, :)
        end do
    end do
    ! New domain.
    a1 = a
    b1 = a + u * (b - a)
    a2 = b1
    b2 = b

end subroutine split_bezier_curve

subroutine extract_bezier_curve(cpw, n, u0, u1, a, b, qw, ae, be)
    !> Extract a Bezier curve between parameters.
    !> cpw - Control points.
    !> n - Number of control points - 1.
    !> u0 - Starting parameter (0 <= u0 < u1).
    !> u1 - Ending parameter (u0 < u1 <= 1).
    !> a - Lower domain of curve (0 <= a < b).
    !> b - Upper domain of curve (a < b <= 1).
    !> qw - Control points of extracted Bezier curve.
    !> ae - Lower domain of extracted curve.
    !> be - Upper domain of extracted curve.

    !f2py intent(in) cpw, n, u0, u1, a, b
    !f2py intent(out) qw, ae, be
    !f2py depend(n) cpw, qw

    ! Input
    integer, intent(in) :: n
    double precision, intent(in) :: u0, u1, a, b
    double precision, intent(in) :: cpw(0:n, 0:3)

    ! Output
    double precision, intent(out) :: ae, be
    double precision, intent(out) :: qw(0:n, 0:3)

    ! Working
    double precision :: u1b, a1, b1, a2, b2, a3, b3
    double precision :: qw1(0:n, 0:3), qw2(0:n, 0:3), qw3(0:n, 0:3)

    call split_bezier_curve(cpw, n, u0, a, b, qw1, a1, b1, qw2, a2, b2)
    u1b = (u1 - u0) / (1.0d0 - u0)
    call split_bezier_curve(qw2, n, u1b, a2, b2, qw, ae, be, qw3, a3, b3)

end subroutine extract_bezier_curve

subroutine split_bezier_surface(cpw, n, m, u, v, au, bu, av, bv, &
                                qw1, qw2, ab1, ab2)
    !> Split Bezier surface into two patches.
    !> cpw - Number of control points - 1.
    !> n - Number of control points - 1 in u-direction.
    !> m - Number of control points - 1 in v-direction.
    !> u - Parameter to split at in v-direction (v should equal 0).
    !> v - Parameter to split at in u-direction (u should equal 0).
    !> au - Lower domain of surface in u-direction.
    !> bu - Upper domain of surface in u-direction.
    !> av - Lower domain of surface in v-direction.
    !> bv - Upper domain of surface in v-direction.
    !> qw1 - Control points of surface 1.
    !> qw2 - Control points of surface 2.
    !> ab1 - Bounds of surface 1 ((au1, bu1), (av1, bv1))
    !> ab2 - Bounds of surface 2 ((au2, bu2), (av2, bv2))

    !f2py intent(in) cpw, n, m, u, v, au, bu, av, bv
    !f2py intent(out) qw1, qw2, ab1, ab2
    !f2py depend(n, m) cpw, qw1, qw2

    ! Input
    integer, intent(in) :: n, m
    double precision, intent(in) :: u, v, au, bu, av, bv
    double precision, intent(in) :: cpw(0:n, 0:m, 0:3)

    ! Output
    double precision, intent(out) :: qw1(0:n, 0:m, 0:3)
    double precision, intent(out) :: qw2(0:n, 0:m, 0:3)
    double precision, intent(out) :: ab1(0:1, 0:1)
    double precision, intent(out) :: ab2(0:1, 0:1)

    ! Working
    integer :: i, j, k

    qw1(:, :, :) = 0.0d0
    qw2(:, :, :) = 0.0d0
    ab1(:, :) = 0.0d0
    ab2(:, :) = 0.0d0

    qw2 = cpw
    if (v .lt. 0.0d0) then
        ! New control points.
        qw1(0, :, :) = qw2(0, :, :)
        do j = 0, m
            do k = 1, n
                do i = 0, n - k
                    qw2(i, j, :) = (1.0d0 - u) * qw2(i, j, :) + &
                                    u * qw2(i + 1, j, :)
                end do
                qw1(k, j, :) = qw2(0, j, :)
            end do
        end do
        ! New domain.
        ab1(0, 0) = au
        ab1(0, 1) = au + u * (bu - au)
        ab1(1, 0) = av
        ab1(1, 1) = bv
        ab2(0, 0) = ab1(0, 1)
        ab2(0, 1) = bu
        ab2(1, 0) = av
        ab2(1, 1) = bv
        return
    elseif (u .lt. 0.0d0) then
        ! New control points.
        qw1(:, 0, :) = qw2(:, 0, :)
        do i = 0, n
            do k = 1, m
                do j = 0, m - k
                    qw2(i, j, :) = (1.0d0 - v) * qw2(i, j, :) + &
                                    v * qw2(i, j + 1, :)
                end do
                qw1(i, k, :) = qw2(i, 0, :)
            end do
        end do
        ! New domain.
        ab1(0, 0) = au
        ab1(0, 1) = bu
        ab1(1, 0) = av
        ab1(1, 1) = av + v * (bv - av)
        ab2(0, 0) = au
        ab2(0, 1) = bu
        ab2(1, 0) = ab1(1, 1)
        ab2(1, 1) = bv
        return
    end if

end subroutine split_bezier_surface

subroutine split_curve(n, p, uk, cpw, u, uk1, qw1, uk2, qw2)
    !> Split a NURBS curve.
    !> n - Number of control points - 1.
    !> p - Degree.
    !> uk - Knot vector.
    !> cpw - Control points.
    !> u - Parameter to split at.
    !> uk1 - Knot vector of curve 1.
    !> qw1 - Control points of curve 1.
    !> uk2 - Knot vector of curve 2.
    !> qw2 - Control points of curve 2.

    ! Input
    integer, intent(in) :: n, p
    double precision, intent(in) :: u
    double precision, intent(in) :: uk(0:n + p + 1)
    double precision, intent(in) :: cpw(0:n, 0:3)

    ! Output
    double precision, allocatable, intent(out) :: uk1(:), uk2(:)
    double precision, allocatable, intent(out) :: qw1(:, :)
    double precision, allocatable, intent(out) :: qw2(:, :)

    ! Working
    integer :: i, k, s, r, nq
    double precision, allocatable :: uq(:)
    double precision, allocatable :: qw(:, :)

    ! Find multiplicity of knot.
    call find_span_mult(n, p, u, uk, k, s)

    ! Insert knot p - s times and update knot vector and control points.
    if (s .ge. p) then
        r = 0
        allocate(uq(0:n + p + 1))
        allocate(qw(0:n, 0:3))
        do i = 0, n + p + 1
            uq(i) = uk(i)
        end do
        do i = 0, n
            qw(i, :) = cpw(i, :)
        end do
    else
        r = p - s
        allocate(uq(0:n + r + p + 1))
        allocate(qw(0:n + r, 0:3))
        call curve_knot_ins(n, p, uk, cpw, u, r, uq, qw)
    end if

    ! Control points.
    nq = n + r
    allocate(qw1(0:k - s, 0:3))
    allocate(qw2(0:nq - (k - s), 0:3))
    qw1(:, :) = 0.0d0
    qw2(:, :) = 0.0d0
    ! Curve 1
    do i = 0, k - s
        qw1(i, :) = qw(i, :)
    end do
    ! Curve 2
    do i = k - s, nq
        qw2(i - (k - s), :) = qw(i, :)
    end do

    ! Knot vectors.
    allocate(uk1(0:k + r + 1))
    allocate(uk2(0:(nq + p + 1) - (k - s + 1) + 1))
    uk1(:) = 0.0d0
    uk2(:) = 0.0d0
    ! Curve 1
    do i = 0, k + r
        uk1(i) = uq(i)
    end do
    uk1(i) = u
    ! Curve 2
    uk2(0) = u
    do i = k - s + 1, nq + p + 1
        uk2((i + 1) - (k - s + 1)) = uq(i)
    end do

end subroutine split_curve

subroutine split_surface(n, p, uk, m, q, vk, cpw, uv, dir, &
                         uk1, vk1, qw1, uk2, vk2, qw2)
    !> Split NURBS surface.
    !> n - Number of control points - 1 in u-direction.
    !> p - Degree in u-direction.
    !> uk - Knot vector in u-direction.
    !> m - Number of control points - 1 in v-direction.
    !> q - Degree in v-direction.
    !> vk - Knot vector in v-direction.
    !> cpw - Control points.
    !> uv - Parameter to split at.
    !> dir - Parameter direction ("u" or "v"). For example,
    !> dir="u", then the surface is split at u=uv and along
    !> the v-direction.
    !> uk1 - Knot vector of surface 1 in u-direction.
    !> vk1 - Knot vector of surface 1 in v-direction.
    !> qw1 - Control points of surface 1.
    !> uk2 - Knot vector of surface 2 in u-direction.
    !> vk2 - Knot vector of surface 2 in v-direction.
    !> qw2 - Control points of surface 2.

    ! Input
    character, intent(in) :: dir
    integer, intent(in) :: n, p, m, q
    double precision, intent(in) :: uv
    double precision, intent(in) :: uk(0:n + p + 1)
    double precision, intent(in) :: vk(0:m + q + 1)
    double precision, intent(in) :: cpw(0:n, 0:m, 0:3)

    ! Output
    double precision, allocatable, intent(out) :: uk1(:), uk2(:)
    double precision, allocatable, intent(out) :: vk1(:), vk2(:)
    double precision, allocatable, intent(out) :: qw1(:, :, :)
    double precision, allocatable, intent(out) :: qw2(:, :, :)

    ! Working
    integer :: i, j, nq, mq, k, s, r
    double precision, allocatable :: uq(:)
    double precision, allocatable :: vq(:)
    double precision, allocatable :: qw(:, :, :)

    if (dir .eq. 'u') then
        ! Find multiplicity of knot.
        call find_span_mult(n, p, uv, uk, k, s)
        ! Insert knot p - s times and update knot vector and control points.
        if (s .ge. p) then
            r = 0
            allocate(uq(0:n + p + 1))
            allocate(qw(0:n, 0:m, 0:3))
            do i = 0, n + p + 1
                uq(i) = uk(i)
            end do
            do i = 0, n
                do j = 0, m
                    qw(i, j, :) = cpw(i, j, :)
                end do
            end do
        else
            r = p - s
            allocate(uq(0:n + r + p + 1))
            allocate(vq(0:m + q + 1))
            allocate(qw(0:n + r, 0:m, 0:3))
            call surface_knot_ins(n, p, uk, m, q, vk, cpw, 'u', uv, r, &
                                  n + r + p + 1, m + q + 1, n + r, m, &
                                  uq, vq, qw)
        end if
        nq = n + r
        ! Control points.
        allocate(qw1(0:k - s, 0:m, 0:3))
        allocate(qw2(0:nq - (k - s), 0:m, 0:3))
        qw1(:, :, :) = 0.0d0
        qw2(:, :, :) = 0.0d0
        do j = 0, m
            ! Surface 1.
            do i = 0, k - s
                qw1(i, j, :) = qw(i, j, :)
            end do
            ! Surface 2.
            do i = k - s, nq
                qw2(i - (k - s), j, :) = qw(i, j, :)
            end do
        end do
        ! Knot vector for surface 1.
        allocate(uk1(0:k + r + 1))
        uk1(:) = 0.0d0
        do i = 0, k + r
            uk1(i) = uq(i)
        end do
        uk1(i) = uv
        ! Knot vector for surface 2.
        allocate(uk2(0:(nq + p + 1) - (k - s + 1) + 1))
        uk2(:) = 0.0d0
        uk2(0) = uv
        do i = k - s + 1, nq + p + 1
            uk2((i + 1) - (k - s + 1)) = uq(i)
        end do
        ! Knot vectors in v-direction.
        allocate(vk1(0:m + q + 1))
        allocate(vk2(0:m + q + 1))
        vk1 = vk
        vk2 = vk
        return
    elseif (dir .eq. 'v') then
        ! Find multiplicity of knot.
        call find_span_mult(m, q, uv, vk, k, s)
        ! Insert knot q - s times and update knot vector and
        ! control points.
        if (s .ge. q) then
            r = 0
            allocate(vq(0:m + q + 1))
            allocate(qw(0:n, 0:m, 0:3))
            do i = 0, m + q + 1
                vq(i) = vk(i)
            end do
            do i = 0, n
                do j = 0, m
                    qw(i, j, :) = cpw(i, j, :)
                end do
            end do
        else
            r = q - s
            allocate(uq(0:n + p + 1))
            allocate(vq(0:m + r + q + 1))
            allocate(qw(0:n, 0:m + r, 0:3))
            call surface_knot_ins(n, p, uk, m, q, vk, cpw, 'v', uv, r, &
                                  n + p + 1, m + r + q + 1, n, m + r, &
                                  uq, vq, qw)
        end if
        mq = m + r
        ! Control points.
        allocate(qw1(0:n, 0:k - s, 0:3))
        allocate(qw2(0:n, 0:mq - (k - s), 0:3))
        qw1(:, :, :) = 0.0d0
        qw2(:, :, :) = 0.0d0
        do i = 0, n
            ! Surface 1.
            do j = 0, k - s
                qw1(i, j, :) = qw(i, j, :)
            end do
            ! Surface 2.
            do j = k - s, mq
                qw2(i, j - (k - s), :) = qw(i, j, :)
            end do
        end do
        ! Knot vector for surface 1.
        allocate(vk1(0:k + r + 1))
        vk1(:) = 0.0d0
        do i = 0, k + r
            vk1(i) = vq(i)
        end do
        vk1(i) = uv
        ! Knot vector for surface 2.
        allocate(vk2(0:(mq + q + 1) - (k - s + 1) + 1))
        vk2(:) = 0.0d0
        vk2(0) = uv
        do i = k - s + 1, mq + q + 1
            vk2((i + 1) - (k - s + 1)) = vq(i)
        end do
        ! Knot vectors in u-direction.
        allocate(uk1(0:n + p + 1))
        allocate(uk2(0:n + p + 1))
        uk1 = uk
        uk2 = uk
        return
    end if

end subroutine split_surface

end module divide


	SUBROUTINE FANDBW2(FREQ,DBX,DBY,NPEAK,FAVR,FBW,SKEW)
C
	DATA SPS /120000./
	REAL AMP(2),DBX(1025),DBY(1025),FREQ(1025)
	REAL FCOUNT(2),FAVR(2),FSTD(2),F3MOM(2),FBW(2),SKEW(2)
	DATA NFLLIMP,NFUPLIMP /4, 1024/
C
	CONST1 = (1./41.1)**2		! DO IN (VOLTS/M)**2
	CONST2 = (1./3.79)**2
C
C	CALCULATE BANDWIDTH, ETC.
	NFLLIM = NPEAK/2
	NFLLIM = MAX0(NFLLIM,NFLLIMP+1)
	NFUPLIM = (3*NPEAK)/2
	NFUPLIM = MIN0(NFUPLIM,NFUPLIMP)
C*********
C	THIS CHOICE DID NOT WORK WELL.  IT GAVE NARROW BANDWIDTHS
C	FOR SOME CASES WHEN THE BANDWIDTH WAS WIDE.  FOR EXAMPLE, IT
C	GAVE A BANDWIDTH OF 63.7 HZ FOR 19960421 # 13042040
C	NFLLIM = NPEAK-2
C	NFUPLIM = NPEAK+2
C*********
	AMP(1) = DBX(NPEAK)
	AMP(2) = DBY(NPEAK)
C
	DO NC = 1,2
	  FCOUNT(NC) = 1.E-20
	  FAVR(NC) = 0.
	  FSTD(NC) = 0.
	  F3MOM(NC) = 0.
	  DO N = NFLLIM,NFUPLIM
	    IF(NC.EQ.1) THEN
		VLT = CONST1*10.**(.1*DBX(N))
	    ELSE
		VLT = CONST2*10.**(.1*DBY(N))
	    ENDIF
	    FCOUNT(NC) = FCOUNT(NC) + VLT
	    FAVR(NC) = FAVR(NC) + VLT*FREQ(N)
	    FSTD(NC) = FSTD(NC) + VLT*FREQ(N)**2
	    F3MOM(NC) = F3MOM(NC) + VLT*FREQ(N)**3
	  ENDDO
	  FAVR(NC) = FAVR(NC)/FCOUNT(NC)
	  FSTD(NC) = FSTD(NC)/FCOUNT(NC) - FAVR(NC)**2
	  FBW(NC) = SQRT(AMAX1(FSTD(NC),0.))
	  SKEW(NC) = F3MOM(NC)/FCOUNT(NC) - 3.*FAVR(NC)*FSTD(NC)
     1		 - FAVR(NC)**3
	ENDDO
	PRINT*,'FANDBW2,F,BW',FAVR(1),FBW(1),FAVR(2),FBW(2)
C
	RETURN
	END


subroutine vis_lat(Nm,Nx,Ny,boundary,psi,vis_latt,boundaries)

implicit none

type boundary_grid
  real(8), allocatable,dimension (:,:,:) :: psi
  real(8), allocatable,dimension (:,:,:) :: chi
end type

integer, intent(in) :: boundary(4)
integer, intent(in) :: Nx,Ny,Nm
real(8), dimension(Nm,Nx,Ny), intent(in)  :: psi
real(8), dimension(Nm,Nx,Ny), intent(out) :: vis_latt
type(boundary_grid) :: boundaries(4)
integer :: fac(4)

integer :: i,j,m

vis_latt(:,:,:) = 0.d0

do m=1,Nm
 do i=3,Nx-2
  do j=3,Ny-2

   vis_latt(m,i,j) = psi(m,i+2,j)+psi(m,i-2,j)+psi(m,i,j+2)+psi(m,i,j-2)+ &
                   &2*psi(m,i+1,j+1)+2*psi(m,i+1,j-1)+2*psi(m,i-1,j+1)+2*psi(m,i-1,j-1)- &
                   &8*psi(m,i+1,j)-8*psi(m,i-1,j)-8*psi(m,i,j+1)-8*psi(m,i,j-1)+20*psi(m,i,j)

  end do
 end do
end do

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! IMPLEMENT BOUNDARY CONDITIONS
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

fac=0
do i=1,4
  if(boundary(i)==1) fac(i)=-1
  if(boundary(i)==0) fac(i)=1
enddo

do m=1,Nm

  i=2
  do j=3,Ny-2

   vis_latt(m,i,j) = psi(m,i+2,j)+fac(1)*psi(m,2,j)+psi(m,i,j+2)+psi(m,i,j-2)+ &
                   & 2*psi(m,i+1,j+1)+2*psi(m,i+1,j-1)+2*psi(m,i-1,j+1)+2*psi(m,i-1,j-1)- &
                   & 8*psi(m,i+1,j)-8*psi(m,i-1,j)-8*psi(m,i,j+1)-8*psi(m,i,j-1)+20*psi(m,i,j)

  end do

  i=Nx-1
  do j=3,Ny-2

   vis_latt(m,i,j) =fac(2)*psi(m,Nx-1,j)+psi(m,i-2,j)+psi(m,i,j+2)+psi(m,i,j-2)+ &
                   & 2*psi(m,i+1,j+1)+2*psi(m,i+1,j-1)+2*psi(m,i-1,j+1)+2*psi(m,i-1,j-1)- &
                   & 8*psi(m,i+1,j)-8*psi(m,i-1,j)-8*psi(m,i,j+1)-8*psi(m,i,j-1)+20*psi(m,i,j)

  end do

  j=2
  do i=3,Nx-2

   vis_latt(m,i,j) = psi(m,i+2,j)+psi(m,i-2,j)+psi(m,i,j+2)+fac(3)*psi(m,i,2)+ &
                   & 2*psi(m,i+1,j+1)+2*psi(m,i+1,j-1)+2*psi(m,i-1,j+1)+2*psi(m,i-1,j-1)- &
                   & 8*psi(m,i+1,j)-8*psi(m,i-1,j)-8*psi(m,i,j+1)-8*psi(m,i,j-1)+20*psi(m,i,j)

  end do

  j=Ny-1
  do i=3,Nx-2

   vis_latt(m,i,j) = psi(m,i+2,j)+psi(m,i-2,j)+fac(4)*psi(m,i,Ny-1)+psi(m,i,j-2)+ &
                   & 2*psi(m,i+1,j+1)+2*psi(m,i+1,j-1)+2*psi(m,i-1,j+1)+2*psi(m,i-1,j-1)- &
                   & 8*psi(m,i+1,j)-8*psi(m,i-1,j)-8*psi(m,i,j+1)-8*psi(m,i,j-1)+20*psi(m,i,j)

  end do

  i=2
  j=2

   vis_latt(m,i,j) = psi(m,i+2,j)+fac(1)*psi(m,2,j)+psi(m,i,j+2)+fac(3)*psi(m,i,2)+ &
                   & 2*psi(m,i+1,j+1)+2*psi(m,i+1,j-1)+2*psi(m,i-1,j+1)+2*psi(m,i-1,j-1)- &
                   & 8*psi(m,i+1,j)-8*psi(m,i-1,j)-8*psi(m,i,j+1)-8*psi(m,i,j-1)+20*psi(m,i,j)

  i=Nx-1
  j=2

   vis_latt(m,i,j) =fac(2)*psi(m,Nx-1,j)+psi(m,i-2,j)+psi(m,i,j+2)+fac(3)*psi(m,i,2)+ &
                   & 2*psi(m,i+1,j+1)+2*psi(m,i+1,j-1)+2*psi(m,i-1,j+1)+2*psi(m,i-1,j-1)- &
                   & 8*psi(m,i+1,j)-8*psi(m,i-1,j)-8*psi(m,i,j+1)-8*psi(m,i,j-1)+20*psi(m,i,j)

  i=2
  j=Ny-1

   vis_latt(m,i,j) = psi(m,i+2,j)+fac(1)*psi(m,2,j)+fac(4)*psi(m,i,Ny-1)+psi(m,i,j-2)+ &
                   & 2*psi(m,i+1,j+1)+2*psi(m,i+1,j-1)+2*psi(m,i-1,j+1)+2*psi(m,i-1,j-1)- &
                   & 8*psi(m,i+1,j)-8*psi(m,i-1,j)-8*psi(m,i,j+1)-8*psi(m,i,j-1)+20*psi(m,i,j)

  i=Nx-1
  j=Ny-1

   vis_latt(m,i,j) =fac(2)*psi(m,Nx-1,j)+psi(m,i-2,j)+fac(4)*psi(m,i,Ny-1)+psi(m,i,j-2)+ &
                   & 2*psi(m,i+1,j+1)+2*psi(m,i+1,j-1)+2*psi(m,i-1,j+1)+2*psi(m,i-1,j-1)- &
                   & 8*psi(m,i+1,j)-8*psi(m,i-1,j)-8*psi(m,i,j+1)-8*psi(m,i,j-1)+20*psi(m,i,j)

end do

! fix interface boundaries
! add missing boundary terms

if(boundary(1)==2) then
  do m=1,Nm
    i=2
    do j=2,Ny-1
      vis_latt(m,i,j) = vis_latt(m,i,j)+boundaries(1)%psi(m,i-2,j)
    enddo
  enddo
endif

if(boundary(2)==2) then
  do m=1,Nm
    i=Nx-1
    do j=2,Ny-1
      vis_latt(m,i,j) = vis_latt(m,i,j)+boundaries(2)%psi(m,i+2,j)
    enddo
  enddo
endif

if(boundary(3)==2) then
  do m=1,Nm
    j=2
    do i=2,Nx-1
      vis_latt(m,i,j) = vis_latt(m,i,j)+boundaries(3)%psi(m,i,j-2)
    enddo
  enddo
endif

if(boundary(4)==2) then
  do m=1,Nm
    j=Ny-1
    do i=2,Nx-1
      vis_latt(m,i,j) = vis_latt(m,i,j)+boundaries(4)%psi(m,i,j+2)
    enddo
  enddo
endif

end


module global_variables
  implicit none
  real(8),parameter :: pi = 4d0*atan(1d0)

  real(8),parameter :: lambda_int = 1.0d0

! grid
  integer :: nx
  real(8) :: length_x, dx
  real(8),allocatable :: xn(:)

! wavefunction
  real(8),allocatable :: wfn(:,:),wfn_t(:,:),hwfn_t(:,:)
  real(8),allocatable :: v_ext(:), v_int(:,:), v_all(:,:)

  real(8) :: eps_gs
  real(8),allocatable :: rho_gs(:)

contains
  function erf_x(x) result(y)
    real(8),intent(in) :: x
    real(8),parameter :: epsilon_s = 1d-3
    real(8) :: y

    if(abs(x) > epsilon_s)then
      y = erf(x)/x
    else
      y = 2d0/sqrt(pi)*( 1d0 - x**2/3d0 + x**4/10d0 - x**6/42d0 + x**8/216d0)
    end if

  end function erf_x

end module global_variables
!-------------------------------------------------------------------------------
program main
  use global_variables
  implicit none

  call input
  call initialize

  call cg_gs
  call calc_hartree_fock
!  call ks_inversion
!  call scf_ks

end program main
!-------------------------------------------------------------------------------
subroutine input
  use global_variables
  implicit none

  nx = 600
  length_x = 60d0
  dx = length_x/nx

end subroutine input
!-------------------------------------------------------------------------------
subroutine initialize
  use global_variables
  implicit none
  integer :: ix, iy
  real(8) :: r

  allocate(wfn(0:nx,0:nx))
  allocate(hwfn_t(0:nx,0:nx))
  allocate(wfn_t(0-4:nx+4,0-4:nx+4))
  wfn_t = 0d0

  allocate(rho_gs(0:nx))
  allocate(v_ext(0:nx),v_int(0:nx,0:nx),v_all(0:nx,0:nx))

  allocate(xn(0:nx))
  do ix = 0,nx
    xn(ix) = -0.5d0*length_x + dx*ix
  end do

! external potential
  do ix = 0,nx
    v_ext(ix) = -2d0/sqrt(0.5d0**2+xn(ix)**2)
!    v_ext(ix) = -1d0/sqrt(2d0+xn(ix)**2)
  end do

! e-e interaction
  do iy = 0,nx
    do ix = 0,nx
      v_int(ix,iy) = lambda_int/sqrt(0.5d0**2+(xn(ix)-xn(iy))**2)
!      v_int(ix,iy) = 0d0
    end do
  end do

  do iy = 0,nx
    do ix = 0,nx
      v_all(ix,iy) = v_ext(ix) + v_ext(iy) + v_int(ix,iy)
    end do
  end do

end subroutine initialize
!-------------------------------------------------------------------------------
subroutine laplacian(wfn_in,Lwfn_out,fact)
  use global_variables
  real(8),intent(in) :: wfn_in(0:nx,0:nx), fact
  real(8),intent(out) :: Lwfn_out(0:nx,0:nx)
  real(8),parameter :: ct0 = -2d0, ct1 = 1d0
  real(8) :: c0,c1
  integer :: ix,iy

  c0 = 2d0*fact*ct0/dx**2
  c1 = fact*ct1/dx**2

  wfn_t(0:nx,0:nx) = wfn_in(0:nx,0:nx)

  do iy = 0,nx
    do ix = 0,nx

      Lwfn_out(ix,iy) = c0*wfn_t(ix,iy) &
        +c1*( wfn_t(ix+1,iy) + wfn_t(ix-1,iy) + wfn_t(ix,iy+1) + wfn_t(ix,iy-1) )

    end do
  end do

end subroutine laplacian
!-------------------------------------------------------------------------------
subroutine hpsi(wfn_in,hwfn_out)
  use global_variables
  real(8),intent(in) :: wfn_in(0:nx,0:nx)
  real(8),intent(out) :: hwfn_out(0:nx,0:nx)

  call laplacian(wfn_in,hwfn_out,-0.5d0)
  hwfn_out = hwfn_out + v_all*wfn_in

end subroutine hpsi
!-------------------------------------------------------------------------------
subroutine cg_gs
  use global_variables
  implicit none
  integer :: ncg, icg
  real(8),parameter :: res_epsilon = 1d-12
  real(8),allocatable :: xvec(:,:),gvec(:,:),pvec(:,:)
  real(8),allocatable :: hxvec(:,:),hpvec(:,:)
  real(8) :: gg0, gg, xx, xhx, pp, php, xp, xhp
  real(8) :: alpha, beta, aa, bb, cc, ss, lambda, res
  integer :: ix,iy

  ncg = 300

  allocate(xvec(0:nx,0:nx),pvec(0:nx,0:nx),gvec(0:nx,0:nx))
  allocate(hxvec(0:nx,0:nx),hpvec(0:nx,0:nx))

  do iy = 0,nx
    do ix = 0,nx
      wfn(ix,iy) = exp(-0.5d0*(xn(ix)-1d0)**2)*exp(-0.5d0*(xn(iy)+2d0)**2)
    end do
  end do

  do iy = 0,nx
    do ix = 0,nx
      xvec(ix,iy) = wfn(ix,iy) + wfn(iy,ix)
    end do
  end do
  ss = sum(xvec**2)*dx**2
  xvec = xvec/sqrt(ss)

  xx = sum(xvec**2)*dx**2
  call hpsi(xvec,hxvec)
  xhx = sum(xvec*hxvec)*dx**2
  lambda = xhx/xx

  res = sum(abs(hxvec-lambda*xvec)**2)*dx**2/xx

  do icg = 1,ncg

    gvec = 2d0*(hxvec - lambda*xvec)/xx
    gg0  = sum(gvec**2)*dx**2
    select case(icg)
    case(1)
      pvec = -gvec
    case default
      beta = gg0/gg
      pvec = -gvec + beta*pvec
    end select
    gg = gg0

    call hpsi(pvec, hpvec)
    pp  = sum(pvec**2)*dx**2
    php = sum(pvec*hpvec)*dx**2
    xp  = sum(pvec*xvec)*dx**2
    xhp = sum(hxvec*pvec)*dx**2

    aa=php*xp-xhp*pp
    bb=php*xx-xhx*pp
    cc=xhp*xx-xhx*xp
    ss=bb**2-4d0*aa*cc
    if(ss > 0d0)then
      alpha=(-bb+sqrt(ss))/(2d0*aa)
    else
      exit
    end if

    xvec = xvec + alpha*pvec
    call hpsi(xvec, hxvec)
    xx  = sum(xvec**2)*dx**2
    xhx = sum(xvec*hxvec)*dx**2
    lambda = xhx/xx

    res = sum(abs(hxvec-lambda*xvec)**2)*dx**2/xx
    if(res<res_epsilon)exit

  end do

! symmetrize
  wfn = xvec
  do iy = 0,nx
    do ix = 0,nx
      xvec(ix,iy) = wfn(ix,iy) + wfn(iy,ix)
    end do
  end do
  ss = sum(xvec**2)*dx**2
  xvec = xvec/sqrt(ss)

  call hpsi(xvec, hxvec)
  xx  = sum(xvec**2)*dx**2
  xhx = sum(xvec*hxvec)*dx**2
  lambda = xhx/xx
  res = sum(abs(hxvec-lambda*xvec)**2)*dx**2/xx
  xvec = xvec/xx
  write(*,*)"icg =",icg
  write(*,"(A,2x,2e26.16e3)")"lambda,res=",lambda,res

  wfn = xvec
  eps_gs = lambda

  do ix = 0,nx
    rho_gs(ix) = sum(wfn(:,ix)**2)*dx
  end do

  ss = sum(rho_gs)*dx
  rho_gs = rho_gs/sqrt(ss)

  open(20,file='rho_gs.out')
  do ix = 0,nx
    write(20,"(999e26.16e3)")xn(ix),rho_gs(ix)
  end do
  close(20)

end subroutine cg_gs
!-------------------------------------------------------------------------------
subroutine calc_hartree_fock
  use global_variables
  implicit none
  real(8) :: wfn_hf(0:nx), hwfn_1p_t(0:nx)
  real(8) :: wfn_ks(0:nx)
  real(8) :: v_hf(0:nx), rho_1p(0:nx)
  real(8) :: ss
  integer :: ix,iy
  real(8) :: eps, res
  integer :: iscf, nscf
  real(8) :: dt
  real(8) :: ss_se_hf, ss_se_ks, ss_hf_ks

  nscf = 2000
  dt = 0.01d0

  do ix = 0,nx
     wfn_hf(ix) = sqrt(rho_gs(ix))
  end do
  ss = sum(wfn_hf**2)*dx
  wfn_hf = wfn_hf/sqrt(ss)
  wfn_ks = wfn_hf

  rho_1p = wfn_hf**2
  v_hf = matmul(v_int, rho_1p)*dx + v_ext

  do iscf = 1, nscf
     call laplacian_1p(wfn_hf,hwfn_1p_t, -0.5d0)
     hwfn_1p_t = hwfn_1p_t + wfn_hf*v_hf

     eps = sum(wfn_hf*hwfn_1p_t)*dx
     res = sum((hwfn_1p_t - eps*wfn_hf)**2)*dx
     write(*,"(I7,2x,2e16.6e3)")iscf,eps,res

     wfn_hf  = wfn_hf  - dt*hwfn_1p_t

     ss = sum(wfn_hf**2)*dx
     wfn_hf = wfn_hf/sqrt(ss)

     rho_1p = wfn_hf**2
     v_hf = matmul(v_int, rho_1p)*dx + v_ext

  end do

  ss_se_hf = 0d0
  ss_se_ks = 0d0
  ss_hf_ks = 0d0

  do iy = 0,nx
     do ix = 0,nx

        ss_se_hf = ss_se_hf + wfn(ix,iy)*wfn_hf(ix)*wfn_hf(iy)
        ss_se_ks = ss_se_ks + wfn(ix,iy)*wfn_ks(ix)*wfn_ks(iy)
        ss_hf_ks = ss_hf_ks + wfn_hf(ix)*wfn_hf(iy)*wfn_ks(ix)*wfn_ks(iy)

     end do
  end do

  ss_se_hf = (ss_se_hf*dx**2)**2
  ss_se_ks = (ss_se_ks*dx**2)**2
  ss_hf_ks = (ss_hf_ks*dx**2)**2

  write(*,"(999e26.16e3)")lambda_int,ss_se_hf,ss_se_ks,ss_hf_ks

end subroutine calc_hartree_fock
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
subroutine laplacian_1p(wfn_in,Lwfn_out,fact)
  use global_variables
  real(8),intent(in) :: wfn_in(0:nx), fact
  real(8),intent(out) :: Lwfn_out(0:nx)
  real(8) :: wfn_tmp(-1:nx+1)
  real(8),parameter :: ct0 = -2d0, ct1 = 1d0
  real(8) :: c0,c1
  integer :: ix,iy

  c0 = fact*ct0/dx**2
  c1 = fact*ct1/dx**2

  wfn_tmp(-1) = 0d0
  wfn_tmp(0:nx) = wfn_in(0:nx)
  wfn_tmp(nx+1) = 0d0

    do ix = 0,nx
      Lwfn_out(ix) = c0*wfn_tmp(ix) +c1*( wfn_tmp(ix+1) + wfn_tmp(ix-1))
    end do

  end subroutine laplacian_1p
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------


c -----------------------------------------------------------
C NCLFORTSTART
      SUBROUTINE DRCM2POINTS(NGRD,NYI,NXI,YI,XI,FI,NXYO,YO,XO,FO
     +                      ,XMSG,OPT,NCRIT,KVAL,IER)
      IMPLICIT NONE
      INTEGER NGRD,NXI,NYI,NXYO,OPT,NCRIT,KVAL,IER
      DOUBLE PRECISION XI(NXI,NYI),YI(NXI,NYI),FI(NXI,NYI,NGRD)
      DOUBLE PRECISION XO(NXYO),YO(NXYO),FO(NXYO,NGRD),XMSG
C NCLEND

C This is written  with GNU f77 acceptable extensions
c .   This could be improved considerably with f90

c nomenclature:
c .   nxi,nyi - lengths of xi,yi and dimensions of fi (must be >= 2)
c .   xi      - coordinates of fi (eg, lon [2D] )
c .   yi      - coordinates of fi (eg, lat [2D] )
c .   fi      - functional input values [2D]
c .   nxyo    - number of output points
c .   xo      - lon coordinates of fo (eg, lon [1D])
c .   yo      - lat coordinates of fo (eg, lat [1D])
c .   fo      - functional output values [interpolated]
c .   xmsg    - missing code
c .   opt     - 0/1 = inv distance, 2 = bilinear
c .   ier     - error code
c .             =0;   no error
c .             =1;   not enough points in input/output array
c .             =2/3; xi or yi are not monotonically increasing
c .             =4/5; xo or yo are not monotonically increasing
c
c                              local
      INTEGER NG,NX,NY,NXY,NEXACT,IX,IY,M,N,NW,NER,K
      DOUBLE PRECISION FW(2,2),W(2,2),SUMF,SUMW,CHKLAT(NYI),CHKLON(NXI)
      DOUBLE PRECISION DGCDIST, WX, WY
      DOUBLE PRECISION REARTH, DLAT, PI, RAD, DKM, DIST
c                              error checking
      IER = 0
      IF (NXI.LE.1 .OR. NYI.LE.1 .OR. NXYO.LE.0) THEN
          IER = 1
          RETURN
      END IF
      IF (IER.NE.0) RETURN

      DO NY = 1,NYI
          CHKLAT(NY) = YI(1,NY)
c c c    print *,"chklat: ny=",ny,"  chklat=",chklat(ny)
      END DO
      CALL DMONOINC(CHKLAT,NYI,IER,NER)
      IF (IER.NE.0) RETURN

      DO NX = 1,NXI
          CHKLON(NX) = XI(NX,1)
c c c    print *,"chklon: nx=",nx,"  chklon=",chklon(nx)
      END DO
      CALL DMONOINC(CHKLAT,NYI,IER,NER)
      IF (IER.NE.0) RETURN

C ORIGINAL  (k = op, never implemented)
      IF (KVAL.LE.0) THEN
         K = 1
      ELSE
         K = KVAL
      END IF
      DO NG = 1,NGRD
        DO NXY = 1,NXYO
           FO(NXY,NG) = XMSG
        END DO
      END DO
c                              main loop [exact matches]
      NEXACT = 0
      DO NXY = 1,NXYO

          DO IY = 1,NYI
              DO IX = 1,NXI
                  IF (XO(NXY).EQ.XI(IX,IY) .AND.
     +                YO(NXY).EQ.YI(IX,IY)) THEN
                      DO NG = 1,NGRD
                         FO(NXY,NG) = FI(IX,IY,NG)
                         NEXACT     = NEXACT + 1
                      END DO
                      GO TO 10
                  END IF
              END DO
          END DO

   10     CONTINUE
      END DO

c c c print *, "nexact=",nexact
c                              main loop [interpolation]
      DO NXY = 1,NXYO

              DO IY = 1,NYI - K
                DO IX = 1,NXI - K
                   IF (XO(NXY).GE.XI(IX,IY) .AND.
     +                 XO(NXY).LE.XI(IX+K,IY) .AND.
     +                 YO(NXY).GE.YI(IX,IY) .AND.
     +                 YO(NXY).LE.YI(IX,IY+K)) THEN

                   IF (ABS(OPT).EQ.2) THEN
                       WX = (XO(NXY)-XI(IX,IY))/
     +                      (XI(IX+K,IY)-XI(IX,IY))
                       WY = (YO(NXY)-YI(IX,IY))/
     +                      (YI(IX,IY+K)-YI(IX,IY))
                       W(1,1) = (1.D0-WX)*(1.D0-WY)
                       W(2,1) = WX*(1.D0-WY)
                       W(1,2) = (1.D0-WX)*WY
                       W(2,2) = WX*WY
                   ELSE
                       W(1,1) = (1.D0/DGCDIST(YO(NXY),XO(NXY),
     +                           YI(IX,IY),XI(IX,IY),2))**2
                       W(2,1) = (1.D0/DGCDIST(YO(NXY),XO(NXY),
     +                           YI(IX+K,IY),XI(IX+K,IY),2))**2
                       W(1,2) = (1.D0/DGCDIST(YO(NXY),XO(NXY),
     +                           YI(IX,IY+K),XI(IX,IY+K),2))**2
                       W(2,2) = (1.D0/DGCDIST(YO(NXY),XO(NXY),
     +                           YI(IX+K,IY+K),XI(IX+K,IY+K),2))**2
                   END IF

                   DO NG = 1,NGRD
                      IF (FO(NXY,NG).EQ.XMSG) THEN

                          FW(1,1) = FI(IX,IY,NG)
                          FW(2,1) = FI(IX+K,IY,NG)
                          FW(1,2) = FI(IX,IY+K,NG)
                          FW(2,2) = FI(IX+K,IY+K,NG)

                          NW = 0
                          SUMF = 0.0D0
                          SUMW = 0.0D0
                          DO N = 1,2
                              DO M = 1,2
                                  IF (FW(M,N).NE.XMSG) THEN
                                      SUMF = SUMF + FW(M,N)*W(M,N)
                                      SUMW = SUMW + W(M,N)
                                      NW = NW + 1
                                  END IF
                              END DO
                          END DO
c                                             nw >=3 arbitrary
                          IF (NW.GE.NCRIT .AND. SUMW.GT.0.D0) THEN
                              FO(NXY,NG) = SUMF/SUMW
                          END IF
                      END IF
                    END DO
                    GO TO 20
                  END IF
                END DO
              END DO

   20         CONTINUE
      END DO

C Are all the output points filled in? Check the 1st grid
C If so, return

      DO NG = 1,NGRD
        DO NXY = 1,NXYO
           IF (FO(NXY,NG).EQ.XMSG) GO TO 30
        END DO
      END DO
      RETURN

C only enter if some points are not interpolated to
C DLAT is arbitrary.  It ould be made an option.
C DLAT is expressed in terms of degrees of latitude.
C DKM  is DLAT in KILOMETERS

   30 REARTH= 6371D0
      DLAT  = 5
      PI    = 4D0*ATAN(1.0D0)
      RAD   = PI/180D0
      DKM   = DLAT*(2D0*PI*REARTH)/360D0

C LOOP OVER EACH GRID ... INEFFICIENT
C THE RUB IS THAT SOME LEVELS COULD HAVE XMSG.

      DO NG = 1,NGRD

        DO NXY = 1,NXYO
           IF(FO(NXY,NG).EQ.XMSG) THEN

C FIND ALL GRID POINTS WITHIN 'DKM' KILOMETERS OF PT

              NW   = 0
              SUMF = 0.0D0
              SUMW = 0.0D0

              DO IY = 1,NYI
                DO IX = 1,NXI
                   IF ((YI(IX,IY).GE.YO(NXY)-DLAT)  .AND.
     +                 (YI(IX,IY).LE.YO(NXY)+DLAT)) THEN
                        DIST = DGCDIST(YO(NXY),XO(NXY)
     +                                ,YI(IX,IY),XI(IX,IY),2)
                        IF (DIST.LE.DKM .AND. DIST.GT.0.0D0 .AND.
     +                      FI(IX,IY,NG).NE.XMSG) THEN
                            DIST = 1.0D0/DIST**2
                            SUMF = SUMF + FI(IX,IY,NG)*DIST
                            SUMW = SUMW + DIST
                            NW   = NW + 1
                        END IF
                   END IF
                END DO
              END DO

C C C         IF (NW.GE.NCRIT .AND. SUMW.GT. 0.0D0) THEN
              IF (SUMW.GT.0.0D0) THEN
                  FO(NXY,NG) = SUMF/SUMW
              END IF
           END IF
        END DO
      END DO

      RETURN
      END


!-----------------------------------------------------------------------
!
! RAdS Jan12.
! Copyright (C) 2011-2014 by Rodrigo Alvares de Souza.
! Mail: <rsouza01@gmail.com>. Web: "http://www.astro.iag.usp.br/~rsouza/".
! This program may be copied and/or distributed freely. See the
! _ terms and conditions in the files in the doc/ subdirectory.
!
!
! MODULE: stat_module
!
!> @author
!> Rodrigo Souza
!
! DESCRIPTION:
!> Information theory related stuff
!
!-----------------------------------------------------------------------
module stat_module
use types
use global_constants
use config_module
use util

    implicit none

    contains

    double precision function calc_infor_entropy(parameters, t, Y, V)
    implicit none
        type(ConfigParameters) :: parameters
        double precision :: t
        double precision :: Y(N_DIFF_EQUATIONS)
        double precision :: V(N_VARIABLES)

        double precision :: delta_radius
        double precision :: rho
        double precision :: radius

        calc_infor_entropy = 0.

        if (V(IDX_ENERGY_DENSITY_BAR) > 0.) then

            radius = (parameters%scale_radius * t) * &
                CONVERSION_LENGTH(parameters%UNIT_SYSTEM)

            delta_radius = (parameters%scale_radius * parameters%diff_eq_step) * &
                CONVERSION_LENGTH(parameters%UNIT_SYSTEM)
            !write(*,*) "(radius, delta_radius) = (", radius, ", ", delta_radius, ")"

            rho = V(IDX_ENERGY_DENSITY_BAR) * parameters%RHO_0
            !write(*,*) "(rho) = (", rho, ")"

            !write(*,*) radius, ",", rho

            calc_infor_entropy = - parameters%K_entropy * &
                rho * log_n(rho, parameters%log_base_calc_infor_entropy) * &
                    4 * const_pi * radius**2. * delta_radius

            !write(*,*) "(coord_radial, densidade, delta_raio, I_parcial) = (", &
            !    radius, ", ", rho, ", ", delta_radius, ", ", calc_infor_entropy, ")"

        end if

        !write(*,*) "(infor_entropy, radius, delta_eta, rho) = (", calc_infor_entropy, ", ", radius, ", ", delta_eta, ", ", rho, ")"

    end function calc_infor_entropy

    double precision function calc_infor_disequilibrium(parameters, t, Y, V)
    implicit none
        type(ConfigParameters) :: parameters
        double precision :: t
        double precision :: Y(N_DIFF_EQUATIONS)
        double precision :: V(N_VARIABLES)

        double precision :: radius
        double precision :: delta_radius
        double precision :: rho

        delta_radius = (parameters%scale_radius * parameters%diff_eq_step) * &
            CONVERSION_LENGTH(parameters%UNIT_SYSTEM)

        radius = (parameters%scale_radius * t) * &
            CONVERSION_LENGTH(parameters%UNIT_SYSTEM)

        rho = V(IDX_ENERGY_DENSITY_BAR) * parameters%RHO_0

        calc_infor_disequilibrium = parameters%K_entropy * rho**2 * 4. * const_pi * radius**2. * delta_radius

    end function calc_infor_disequilibrium

    double precision function calc_baryon_number(parameters, t, Y, V)
    implicit none
        type(ConfigParameters) :: parameters
        double precision :: t
        double precision :: Y(N_DIFF_EQUATIONS)
        double precision :: V(N_VARIABLES)

        double precision :: delta_eta
        double precision :: metric_term
        double precision :: barionic_density
        double precision :: radius
        double precision :: mass
        double precision :: scale_radius
        double precision :: scale_mass

        scale_radius = parameters%scale_radius

        scale_mass = parameters%scale_mass

        delta_eta = scale_radius * parameters%diff_eq_step

        radius = scale_radius * t

        mass = scale_mass * V(IDX_MASS_BAR)

        barionic_density = parameters%BARYONIC_DENSITY_0 * &
            barionic_density_from_eos_table(parameters, V(IDX_ENERGY_DENSITY_BAR))

        metric_term = 1. - 2. * GRAVITATIONAL_CONSTANT(parameters%UNIT_SYSTEM) * mass / &
            (LIGHT_SPEED_SCALE(parameters%UNIT_SYSTEM)**2. * radius)

        calc_baryon_number = 4. * const_pi * (metric_term)**(-0.5) * &
            radius** 2. * barionic_density * delta_eta

        !write (*, *) "(radius, barionic_density, calc_baryon_number) = (", radius, &
        !   ", " , barionic_density, ", ", calc_baryon_number, ")"

        !write(*,*) "(metric_term, calc_baryon_number) = ", metric_term, calc_baryon_number

    end function calc_baryon_number

end module stat_module


module sparse_ir
    implicit none

    ! Matrix decomposed in SVD for fitting
    type DecomposedMatrix
        complex(kind(0d0)), pointer :: a(:, :) ! Original matrix
        double precision, pointer :: inv_s(:) ! Inverse of singular values
        complex(kind(0d0)), pointer :: ut(:, :), v(:, :)
        integer :: m, n, ns
    end type

    ! Sampling points, basis functions
    type IR
        integer :: size, ntau, nfreq_f, nfreq_b
        double precision :: beta, lambda, wmax, eps, eps_svd
        double precision, pointer :: s(:), tau(:), x(:)
        integer, pointer :: freq_f(:), freq_b(:)
        complex(kind(0d0)), pointer :: u_data(:,:)
        complex(kind(0d0)), pointer :: uhat_f_data(:,:), uhat_b_data(:,:)
        type(DecomposedMatrix) :: u
        type(DecomposedMatrix) :: uhat_f, uhat_b
    end type

    contains

    subroutine init_ir(obj, beta, lambda, eps, s, x, freq_f, freq_b, u, uhat_f, uhat_b, eps_svd)
        type(IR), intent(inout) :: obj
        double precision, intent(in) :: beta, lambda, eps, s(:), x(:), eps_svd
        complex(kind(0d0)), intent(in) :: u(:,:), uhat_f(:, :), uhat_b(:, :)
        integer, intent(in) :: freq_f(:), freq_b(:)

        obj%size = size(s)
        obj%ntau = size(x)
        obj%nfreq_f = size(freq_f)
        obj%nfreq_b = size(freq_b)
        obj%lambda = lambda
        obj%eps = eps
        obj%eps_svd = eps_svd

        allocate(obj%x(obj%ntau))
        obj%x = x

        allocate(obj%tau(obj%ntau))

        allocate(obj%s(obj%size))
        obj%s = sqrt(5.0d-1*obj%lambda) * s

        allocate(obj%freq_f(obj%nfreq_f))
        obj%freq_f = freq_f

        allocate(obj%freq_b(obj%nfreq_b))
        obj%freq_b = freq_b

        allocate(obj%u_data(obj%ntau, obj%size))
        obj%u_data = u

        allocate(obj%uhat_f_data(obj%nfreq_f, obj%size))
        obj%uhat_f_data = uhat_f

        allocate(obj%uhat_b_data(obj%nfreq_b, obj%size))
        obj%uhat_b_data = uhat_b

        ! Here we define basis sets for the input value of beta.
        call set_beta(obj, beta)
    end subroutine

    subroutine set_beta(obj, beta)
        type(IR), intent(inout) :: obj
        double precision, intent(in) :: beta

        obj%beta = beta
        obj%wmax = obj%lambda / beta

        obj%tau = 5.0d-1 * beta * (obj%x + 1.d0)

        obj%u = decompose(sqrt(2.0d0/beta)*obj%u_data, obj%eps_svd)
        obj%uhat_f = decompose(sqrt(beta) * obj%uhat_f_data, obj%eps_svd)
        obj%uhat_b = decompose(sqrt(beta) * obj%uhat_b_data, obj%eps_svd)
    end subroutine

    ! SVD of matrix a. Singular values smaller than eps * the largest one are dropped.
    function decompose(a, eps) result(dmat)
        complex(kind(0d0)), intent(in) :: a(:, :)
        double precision, intent(in) :: eps

        integer :: i, info, lda, ldu, ldvt, lwork, m, n, mn, ns
        complex(kind(0d0)), allocatable :: a_copy(:, :), u(:, :), &
            vt(:, :), work(:)
        double precision, allocatable :: rwork(:), s(:)
        integer, allocatable :: iwork(:)
        type(DecomposedMatrix)::dmat

        m = size(a, 1)
        n = size(a, 2)
        mn = min(m, n)
        lda = m
        ldu = m
        ldvt = n
        lwork = mn*mn + 3*mn

        allocate(work(lwork), a_copy(m,n), s(m), u(ldu,m), vt(ldvt,n), rwork((5*mn+7)*mn), iwork(8*mn))

        a_copy(1:m, 1:n) = a(1:m, 1:n)
        call zgesdd('S', m, n, a_copy, lda, s, u, ldu, vt, ldvt, work, lwork, rwork, iwork, info)

        if (info /= 0) then
            stop 'Failure in ZGESDD.'
        end if

        ! Number of relevant singular values s(i)/s(1) >= eps
        ns = 0
        do i = 1, mn
            if (s(i)/s(1) < eps) then
                exit
            end if
            ns = ns + 1
        end do

        allocate(dmat%a(m, n))
        allocate(dmat%inv_s(ns))
        allocate(dmat%ut(ns, m))
        allocate(dmat%v(n, ns))

        dmat%a = a
        dmat%inv_s(1:ns) = 1/s(1:ns)
        dmat%ut(1:ns, 1:m) = conjg(transpose(u(1:m, 1:ns)))
        dmat%v(1:n, 1:ns) = conjg(transpose(vt(1:ns, 1:n)))
        dmat%m = size(a, 1)
        dmat%n = size(a, 2)
        dmat%ns = ns

        deallocate(work, a_copy, s, u, vt, rwork, iwork)
    end function

    subroutine fit_matsubara_f(obj, arr, res)
        type(IR), intent(in) :: obj
        complex(kind(0d0)), intent (in) :: arr(:, :)
        complex(kind(0d0)), intent(out) :: res(:, :)
        call fit_impl(arr, obj%uhat_f, res)
    end subroutine

    subroutine fit_matsubara_b(obj, arr, res)
        type(IR), intent(in) :: obj
        complex(kind(0d0)), intent (in) :: arr(:, :)
        complex(kind(0d0)), intent(out) :: res(:, :)
        call fit_impl(arr, obj%uhat_b, res)
    end subroutine

    subroutine fit_tau(obj, arr, res)
        type(IR), intent(in) :: obj
        complex(kind(0d0)), intent (in) :: arr(:, :)
        complex(kind(0d0)), intent(out) :: res(:, :)
        call fit_impl(arr, obj%u, res)
    end subroutine

    subroutine evaluate_tau(obj, arr, res)
        type(IR), intent(in) :: obj
        complex(kind(0d0)), intent (in) :: arr(:, :)
        complex(kind(0d0)), intent(out) :: res(:, :)
        ! TODO: using zgemm
        res = matmul(arr, transpose(obj%u%a))
    end subroutine

    subroutine evaluate_matsubara_f(obj, arr, res)
        type(IR), intent(in) :: obj
        complex(kind(0d0)), intent (in) :: arr(:, :)
        complex(kind(0d0)), intent(out) :: res(:, :)
        ! TODO: using zgemm
        res = matmul(arr, transpose(obj%uhat_f%a))
    end subroutine

    subroutine evaluate_matsubara_b(obj, arr, res)
        type(IR), intent(in) :: obj
        complex(kind(0d0)), intent (in) :: arr(:, :)
        complex(kind(0d0)), intent(out) :: res(:, :)
        ! TODO: using zgemm
        res = matmul(arr, transpose(obj%uhat_b%a))
    end subroutine

    ! Implementation of fit
    subroutine fit_impl(arr, mat, res)
        complex(kind(0d0)), intent (in) :: arr(:, :)
        type(DecomposedMatrix), intent(in) :: mat
        complex(kind(0d0)), intent(out) :: res(:, :)

        complex(kind(0d0)), allocatable :: ut_arr(:, :)

        integer :: nb, m, n, ns, i, j

        ! ut(ns, m)
        ! v(n, ns)
        ! arr(nb, m)
        ! mat(m, n)
        ! ut_arr(ns, nb)
        ! res(nb, n)
        nb = size(arr, 1)
        ns = mat%ns
        m = mat%m
        n = mat%n
        allocate(ut_arr(ns, nb))

        if (size(res, 1) /= nb .or. size(res, 2) /= n) then
            stop 'Invalid size of output array'
        end if

        !ut(ns, m) * arr(nb, m) -> ut_arr(ns, nb)
        ut_arr = 0.0
        call zgemm("n", "t", ns, nb, m, 1.d0, mat%ut, ns, arr, nb, 0.d0, ut_arr, ns)
        do j = 1, ns
            do i = 1, nb
                ut_arr(j, i) = ut_arr(j, i) * mat%inv_s(j)
            end do
        end do

        ! ut_arr(ns, nb) * v(n, ns) -> (nb, n)
        res = 0.0
        call zgemm("t", "t", nb, n, ns, 1.d0, ut_arr, ns, mat%v, n, 0.d0, res, nb)

        deallocate(ut_arr)
    end subroutine

end module


subroutine fcal(omegap,k,a,b,n,f)
implicit none
  real o, meg, expo,gamma, gam1, gam, sn,fn,f,sigma, omega,test
  real, intent(in) :: omegap,k,a,b
  integer i
  integer, intent(in) :: n
  open(10,file='spekterplot.dat',action = "write", status ="replace")
  do i = 1,n
   omega = a + ((b-a)*(i-0.5))/n
   write(*,*) 'omega fra subrutine er', omega
   if (omegap < omega) then
      sigma = 0.09
   else
      sigma = 0.07
   end if
   write(*,*) 'sigma fra subrutine er:',sigma
   o = omegap/omega
   write(*,*) 'o fra subrutine er ',o
   meg = (o)**5
   write(*,*) 'o fra subrutine er ',o
   expo = exp(-(5./4.) * (o**4))
!   write(*,*) 'expo fra subrutine er:', expo
   test = omega/omegap
!   write(*,*) 'omega/omegap fra subrutine er:',test
   gam1 = exp(-(((omega/omegap)-1.)**2) /(2.*(sigma**2)))
!   write(*,*) 'gam1 fra subrutine er:', gam1
   gam = gamma**gam1
!   write(*,*) 'gam fra subrutine er:', gam
   sn = meg*expo*gam*k
   fn = (omega**2) * sn
   f = f + fn
   write(10,*) omega,sn
   write(*,*) 'f fra subrutine er:',f
end do
close(10)
return
end subroutine fcal


	PROGRAM BWTRY
C
	DATA F0,BW /15000., 100./
	REAL SIG(500)
C
	NPT = 100
	MID = NPT/2
	DO N = 1,NPT
	  F = F0 + .1*(N-MID)*BW
C	  SIGT = 1./((F-F0)**2 + BW**2)
	  SIGT = BW**2/((F-F0)**2 + BW**2)
	  SIGT = EXP(-1./SIGT)
	  PRINT*,F,SIGT
	  SIG(N) = 10.*ALOG10(SIGT)
	  WRITE(49,*) F,SIGT,SIG(N)
	ENDDO
	STOP
	END


subroutine mdim_gls(t, y, err, freqs, params, ar, t_ref, coeffs, A)

    !implicit Real*4 (a-h,o-z)
    Real*4, intent(in) :: t(:), y(:), err(:)
    Real*4, intent(in) :: freqs(:), params(:), t_ref
    integer, intent(in) :: ar
    Real*4, intent(out):: coeffs(2*size(freqs)+1+ar)
    Real*4 :: F(size(t),2*size(freqs)+1+ar), Ft(2*size(freqs)+1+ar, size(t)), b(2*size(freqs)+1+ar), y_err(size(t))
    Real*4 , intent(out):: A(2*size(freqs)+1+ar,2*size(freqs)+1+ar)
    Real*4 ::  pi=acos(-1.0)
    integer :: i, j, k, n_dim, delay, LS_INFO, pivot(2*size(freqs)+1+ar)

    n_dim = size(freqs)
    n_data = size(t)
    n_params = size(params)

    do k = 1, 2*n_dim+1+ar
        if (k.EQ.1) then
            do j = 1,n_data
                F(j,k) = 1.0/err(j)
            enddo
        else if ((k.GT.1).AND.(k.LE.(n_dim+1))) then
             do j = 1,n_data
                 F(j,k) = cos(2.0*pi*(t(j)-t_ref)*freqs(k-1))/err(j)
             enddo
        else if ((k.GT.(n_dim+1)).AND.(k.LT.(2*n_dim+2))) then
             do j = 1,n_data
                 F(j,k) = sin(2.0*pi*(t(j)-t_ref)*freqs(k-(n_dim+1)))/err(j)
             enddo
        else if (k.GE.(2*n_dim+2)) then
             delay = k - (2*n_dim+1)
             do j = 1,n_data
                 if (j.GT.delay) then
                    F(j,k) = y(j-delay)*exp((t(j-delay)-t(j))/params(1))/err(j-delay)
                 else
                    F(j,k) = 0.0
                 endif
             enddo
        endif
     enddo

    do i =1,n_data
        y_err(i) = y(i)/err(i)
    enddo
    !arrange linear system F_t*F*theta = F_t*y_e --> A*theta = b
    Ft = transpose(F)
    A = matmul(Ft,F)
    b = matmul(Ft,y_err)
    !solves a system of linear equations A*X = B
    !call DPOTRS('L', n_dim, 1, A, n_dim, b, n_dim, LS_INFO)
    call SGESV(2*n_dim+1+ar, 1, A, 2*n_dim+1+ar, pivot, b, 2*n_dim+1+ar, LS_INFO)
    !fill output vector: fitting coeffs.
    do i = 1,2*n_dim+1+ar
        coeffs(i) = b(i)
    enddo

end subroutine mdim_gls

subroutine model(t, y, freqs, fitting_coeffs, params, y_model_array)
    !computes model according to fitting coefficients, frequencies and params
    double precision, intent(in) :: t(:), y(:), freqs(:), fitting_coeffs(:), params(:)
    double precision, intent(out) :: y_model_array(size(t))
    double precision :: y_model, t_p, t_ref
    double precision :: pi=dacos(-1.0d0)
    integer :: k, n_dim, delay

    t_ref = t(1)
    n_dim = size(freqs)
    n_data = size(t)
    do j = 1, n_data
        y_model = 0.0
        t_p = t(j)
        do k = 1,size(fitting_coeffs)
            if (k.EQ.1) then
                y_model = y_model + fitting_coeffs(k)
            else if ((k.GT.1).AND.(k.LE.(n_dim+1))) then
                y_model = y_model + &
                        fitting_coeffs(k)*cos(2.0*pi*(t_p-t_ref)*freqs(k-1))
            else if ((k.GT.(n_dim+1)).AND.(k.LT.(2*n_dim+2))) then
                y_model = y_model + &
                    fitting_coeffs(k)*sin(2.0*pi*(t_p-t_ref)*freqs((k-(n_dim+1))))
            else if (k.GE.(2*n_dim+2)) then
                    delay = k - (2*n_dim+1)
                    if (j.GT.delay) then
                        y_model = y_model + fitting_coeffs(k)*exp((t(j-delay)-t(j))/params(1))*y(j-delay)
                    endif
            endif
        enddo
        y_model_array(j) = y_model
    enddo

end subroutine model

subroutine chi2(t, y, err, model, chi2_out)
!   computes chi2 between data and model
    double precision, intent(in) :: t(:), y(:), err(:), model(:)
    double precision, intent(out) :: chi2_out
    integer :: i

    chi2_out = 0.0
    do 97 i = 1, size(t)
        chi2_out = chi2_out + (1.0/(err(i)*err(i)))*(y(i) - model(i))**2.0
97  continue

end subroutine chi2

subroutine chi2_0(y, err, chi2_0_out)
!   computes chi2 respect to the mean
    double precision, intent(in) :: y(:), err(:)
    double precision, intent(out) :: chi2_0_out
    double precision :: mean_y
    integer :: i

    chi2_0_out = 0.0
    mean_y = 0.0
    do 96 j = 1,size(y)
        mean_y = mean_y + y(j)
96  continue
    mean_y = mean_y/size(y)

    do 97 i = 1,size(y)
        chi2_0_out = chi2_0_out + &
                  (1.0/(err(i)*err(i)))*(y(i) - mean_y)**2.0
97  continue

end subroutine chi2_0

subroutine residuals(t, y, model, residuals_out)
!   computes chi2 between data and model
    double precision, intent(in) :: t(:), y(:), model(:)
    double precision, intent(out) :: residuals_out(size(t))
    integer :: i

    do 97 i = 1, size(t)
        residuals_out(i) = y(i) - model(i)
97  continue

end subroutine residuals


module pangram
implicit none
contains
  logical function is_pangram(sentance)
    implicit none
    character(*) :: sentance
    logical :: seen(26)
    integer :: i,val

    seen = .false.

    do i = 1,len(sentance)
      val = to_index(sentance(i:i))
      if ( val .ne. 0 ) then
        seen(val:val) = .true.
      end if
    end do

    is_pangram = all(seen)
   end function is_pangram

   integer function to_index(chr)
       implicit none
       character :: chr

       if ((chr .ge. 'a' ) .and. (chr .le. 'z')) then
         to_index = ichar('z') - ichar(chr) + 1
       else if ((chr .ge. 'A' ) .and. (chr .le. 'Z')) then
         to_index = ichar('Z') - ichar(chr) + 1
       else
         to_index = 0
       end if
   end function to_index
end module pangram


!
! forward substitution example
!
      program fs02

      integer n, i, j
      parameter (n=100)

      real a(n,n), b(n)
      real x1, x2, x3

      do i=1, n
         x1 = b(i)
         x2 = x1*x1 + x1
         do j=1, n
            x3 = x1 + x2
            a(i,j) = a(i,j)*x3+x2-1
         enddo
      enddo

      print *, a(5,20)

      end