C
C      ________________________________________________________
C     |                                                        |
C     |               THE FAST FOURIER TRANSFORM               |
C     |             NEW A SUB I = SUM FROM J=1 TO N            |
C     |    EXP(2*PI*SQRT(-1)/N)**((I-1)*(J-1)) OLD A SUB J     |
C     |                                                        |
C     |    INPUT:                                              |
C     |                                                        |
C     |         A     --COEFFICIENTS                           |
C     |                                                        |
C     |         N     --NUMBER OF COEFFICIENTS                 |
C     |                                                        |
C     |    OUTPUT:                                             |
C     |                                                        |
C     |         A     --TRANSFORMED COEFFICIENTS               |
C     |                                                        |
C     |    BUILTIN FUNCTIONS: ACOS,CEXP,CMPLX                  |
C     |________________________________________________________|
C
      SUBROUTINE FFT(A,N,W)
      COMPLEX A(1),W(1),S,T,U,V
      INTEGER D,E,F,G,H,I,J,K,L,M,N,NP,O,P(25)
      DATA P/2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,
     1 73,79,83,89,97/
      DATA NP/25/
      M = N
      F = 0
      U = CMPLX(0.,2.*ACOS(-1.)/N)
C     --------------------------------------------------
C     |*** SOME COMPILERS USE ARCOS INSTEAD OF ACOS ***|
C     --------------------------------------------------
10    IF ( M .EQ. 1 ) GOTO 900
      DO 20 I = 1,NP
20         IF ( (M/P(I))*P(I) .EQ. M ) GOTO 30
      L = M
      GOTO 40
30    L = P(I)
40    O = M
      M = M/L
      V = CEXP(M*U)
      S = (1.,0.)
      H = 0
      IF ( F .EQ. 1 ) GOTO 470
      IF ( L .EQ. 2 ) GOTO 50
      IF ( L .EQ. 3 ) GOTO 170
      GOTO 290
50    GOTO (150,130,110,90),M
60    J = -H
70    I = H + 1
      H = H + M
      E = J + M
      DO 80 K = I,H
80         W(K) = A(J+K) + S*A(E+K)
      J = E
      S = S*V
      IF ( J+H .LT. N ) GOTO 70
      IF ( H .LT. N ) GOTO 60
      F = 1
      GOTO 10
90    J = -H
100   H = H + 1
      E = J + M
      W(H) = A(J+H) + S*A(E+H)
      H = H + 1
      W(H) = A(J+H) + S*A(E+H)
      H = H + 1
      W(H) = A(J+H) + S*A(E+H)
      H = H + 1
      W(H) = A(J+H) + S*A(E+H)
      J = E
      S = S*V
      IF ( J+H .LT. N ) GOTO 100
      IF ( H .LT. N ) GOTO 90
      F = 1
      GOTO 10
110   J = -H
120   H = H + 1
      E = J + M
      W(H) = A(J+H) + S*A(E+H)
      H = H + 1
      W(H) = A(J+H) + S*A(E+H)
      H = H + 1
      W(H) = A(J+H) + S*A(E+H)
      J = E
      S = S*V
      IF ( J+H .LT. N ) GOTO 120
      IF ( H .LT. N ) GOTO 110
      F = 1
      GOTO 10
130   J = -H
140   H = H + 1
      E = J + M
      W(H) = A(J+H) + S*A(E+H)
      H = H + 1
      W(H) = A(J+H) + S*A(E+H)
      J = E
      S = S*V
      IF ( J+H .LT. N ) GOTO 140
      IF ( H .LT. N ) GOTO 130
      F = 1
      GOTO 10
150   J = -H
160   H = H + 1
      E = J + M
      W(H) = A(J+H) + S*A(E+H)
      J = E
      S = S*V
      IF ( J+H .LT. N ) GOTO 160
      IF ( H .LT. N ) GOTO 150
      F = 1
      GOTO 10
170   GOTO (270,250,230,210),M
180   J = -H
190   I = H + 1
      H = H + M
      E = J + M
      D = E + M
      T = S*S
      DO 200 K = I,H
200        W(K) = A(J+K) + S*A(E+K) + T*A(D+K)
      J = D
      S = S*V
      IF ( J+H .LT. N ) GOTO 190
      IF ( H .LT. N ) GOTO 180
      F = 1
      GOTO 10
210   J = -H
220   H = H + 1
      E = J + M
      D = E + M
      T = S*S
      W(H) = A(J+H) + S*A(E+H) + T*A(D+H)
      H = H + 1
      W(H) = A(J+H) + S*A(E+H) + T*A(D+H)
      H = H + 1
      W(H) = A(J+H) + S*A(E+H) + T*A(D+H)
      H = H + 1
      W(H) = A(J+H) + S*A(E+H) + T*A(D+H)
      J = D
      S = S*V
      IF ( J+H .LT. N ) GOTO 220
      IF ( H .LT. N ) GOTO 210
      F = 1
      GOTO 10
230   J = -H
240   H = H + 1
      E = J + M
      D = E + M
      T = S*S
      W(H) = A(J+H) + S*A(E+H) + T*A(D+H)
      H = H + 1
      W(H) = A(J+H) + S*A(E+H) + T*A(D+H)
      H = H + 1
      W(H) = A(J+H) + S*A(E+H) + T*A(D+H)
      J = D
      S = S*V
      IF ( J+H .LT. N ) GOTO 240
      IF ( H .LT. N ) GOTO 230
      F = 1
      GOTO 10
250   J = -H
260   H = H + 1
      E = J + M
      D = E + M
      T = S*S
      W(H) = A(J+H) + S*A(E+H) + T*A(D+H)
      H = H + 1
      W(H) = A(J+H) + S*A(E+H) + T*A(D+H)
      J = D
      S = S*V
      IF ( J+H .LT. N ) GOTO 260
      IF ( H .LT. N ) GOTO 250
      F = 1
      GOTO 10
270   J = -H
280   H = H + 1
      E = J + M
      D = E + M
      T = S*S
      W(H) = A(J+H) + S*A(E+H) + T*A(D+H)
      J = D
      S = S*V
      IF ( J+H .LT. N ) GOTO 280
      IF ( H .LT. N ) GOTO 270
      F = 1
      GOTO 10
290   GOTO (440,410,380,350),M
300   J = -H
310   T = (1.,0.)
      I = H + 1
      H = H + M
      G = J + O
      DO 320 K = I,H
320        W(K) =  (0.,0.)
330   DO 340 K = I,H
340        W(K) = W(K) + T*A(J+K)
      T = T*S
      J = J + M
      IF ( J .LT. G ) GOTO 330
      J = J - M
      S = S*V
      IF ( J+H .LT. N ) GOTO 310
      IF ( H .LT. N ) GOTO 300
      F = 1
      GOTO 10
350   J = -H
360   T = (1.,0.)
      I = H + 1
      E = I + 1
      D = E + 1
      H = H + M
      G = J + O
      W(I) = (0.,0.)
      W(E) = (0.,0.)
      W(D) = (0.,0.)
      W(H) = (0.,0.)
370   W(I) = W(I) + T*A(J+I)
      W(E) = W(E) + T*A(J+E)
      W(D) = W(D) + T*A(J+D)
      W(H) = W(H) + T*A(J+H)
      T = T*S
      J = J + M
      IF ( J .LT. G ) GOTO 370
      J = J - M
      S = S*V
      IF ( J+H .LT. N ) GOTO 360
      IF ( H .LT. N ) GOTO 350
      F = 1
      GOTO 10
380   J = -H
390   T = (1.,0.)
      I = H + 1
      E = I + 1
      H = H + M
      G = J + O
      W(I) = (0.,0.)
      W(E) = (0.,0.)
      W(H) = (0.,0.)
400   W(I) = W(I) + T*A(J+I)
      W(E) = W(E) + T*A(J+E)
      W(H) = W(H) + T*A(J+H)
      T = T*S
      J = J + M
      IF ( J .LT. G ) GOTO 400
      J = J - M
      S = S*V
      IF ( J+H .LT. N ) GOTO 390
      IF ( H .LT. N ) GOTO 380
      F = 1
      GOTO 10
410   J = -H
420   T = (1.,0.)
      I = H + 1
      H = H + M
      G = J + O
      W(I) = (0.,0.)
      W(H) = (0.,0.)
430   W(I) = W(I) + T*A(J+I)
      W(H) = W(H) + T*A(J+H)
      T = T*S
      J = J + M
      IF ( J .LT. G ) GOTO 430
      J = J - M
      S = S*V
      IF ( J+H .LT. N ) GOTO 420
      IF ( H .LT. N ) GOTO 410
      F = 1
      GOTO 10
440   J = -H
450   T = (1.,0.)
      I = H + 1
      H = H + M
      G = J + O
      W(I) = (0.,0.)
460   W(I) = W(I) + T*A(J+I)
      T = T*S
      J = J + M
      IF ( J .LT. G ) GOTO 460
      J = J - M
      S = S*V
      IF ( J+H .LT. N ) GOTO 450
      IF ( H .LT. N ) GOTO 440
      F = 1
      GOTO 10
470   IF ( L .EQ. 2 ) GOTO 480
      IF ( L .EQ. 3 ) GOTO 600
      GOTO 720
480   GOTO (580,560,540,520),M
490   J = -H
500   I = H + 1
      H = H + M
      E = J + M
      DO 510 K = I,H
510        A(K) = W(J+K) + S*W(E+K)
      J = E
      S = S*V
      IF ( J+H .LT. N ) GOTO 500
      IF ( H .LT. N ) GOTO 490
      F = 0
      GOTO 10
520   J = -H
530   H = H + 1
      E = J + M
      A(H) = W(J+H) + S*W(E+H)
      H = H + 1
      A(H) = W(J+H) + S*W(E+H)
      H = H + 1
      A(H) = W(J+H) + S*W(E+H)
      H = H + 1
      A(H) = W(J+H) + S*W(E+H)
      J = E
      S = S*V
      IF ( J+H .LT. N ) GOTO 530
      IF ( H .LT. N ) GOTO 520
      F = 0
      GOTO 10
540   J = -H
550   H = H + 1
      E = J + M
      A(H) = W(J+H) + S*W(E+H)
      H = H + 1
      A(H) = W(J+H) + S*W(E+H)
      H = H + 1
      A(H) = W(J+H) + S*W(E+H)
      J = E
      S = S*V
      IF ( J+H .LT. N ) GOTO 550
      IF ( H .LT. N ) GOTO 540
      F = 0
      GOTO 10
560   J = -H
570   H = H + 1
      E = J + M
      A(H) = W(J+H) + S*W(E+H)
      H = H + 1
      A(H) = W(J+H) + S*W(E+H)
      J = E
      S = S*V
      IF ( J+H .LT. N ) GOTO 570
      IF ( H .LT. N ) GOTO 560
      F = 0
      GOTO 10
580   J = -H
590   H = H + 1
      E = J + M
      A(H) = W(J+H) + S*W(E+H)
      J = E
      S = S*V
      IF ( J+H .LT. N ) GOTO 590
      IF ( H .LT. N ) GOTO 580
      F = 0
      GOTO 10
600   GOTO (700,680,660,640),M
610   J = -H
620   I = H + 1
      H = H + M
      E = J + M
      D = E + M
      T = S*S
      DO 630 K = I,H
630        A(K) = W(J+K) + S*W(E+K) + T*W(D+K)
      J = D
      S = S*V
      IF ( J+H .LT. N ) GOTO 620
      IF ( H .LT. N ) GOTO 610
      F = 0
      GOTO 10
640   J = -H
650   H = H + 1
      E = J + M
      D = E + M
      T = S*S
      A(H) = W(J+H) + S*W(E+H) + T*W(D+H)
      H = H + 1
      A(H) = W(J+H) + S*W(E+H) + T*W(D+H)
      H = H + 1
      A(H) = W(J+H) + S*W(E+H) + T*W(D+H)
      H = H + 1
      A(H) = W(J+H) + S*W(E+H) + T*W(D+H)
      J = D
      S = S*V
      IF ( J+H .LT. N ) GOTO 650
      IF ( H .LT. N ) GOTO 640
      F = 0
      GOTO 10
660   J = -H
670   H = H + 1
      E = J + M
      D = E + M
      T = S*S
      A(H) = W(J+H) + S*W(E+H) + T*W(D+H)
      H = H + 1
      A(H) = W(J+H) + S*W(E+H) + T*W(D+H)
      H = H + 1
      A(H) = W(J+H) + S*W(E+H) + T*W(D+H)
      J = D
      S = S*V
      IF ( J+H .LT. N ) GOTO 670
      IF ( H .LT. N ) GOTO 660
      F = 0
      GOTO 10
680   J = -H
690   H = H + 1
      E = J + M
      D = E + M
      T = S*S
      A(H) = W(J+H) + S*W(E+H) + T*W(D+H)
      H = H + 1
      A(H) = W(J+H) + S*W(E+H) + T*W(D+H)
      J = D
      S = S*V
      IF ( J+H .LT. N ) GOTO 690
      IF ( H .LT. N ) GOTO 680
      F = 0
      GOTO 10
700   J = -H
710   H = H + 1
      E = J + M
      D = E + M
      T = S*S
      A(H) = W(J+H) + S*W(E+H) + T*W(D+H)
      J = D
      S = S*V
      IF ( J+H .LT. N ) GOTO 710
      IF ( H .LT. N ) GOTO 700
      F = 0
      GOTO 10
720   GOTO (870,840,810,780),M
730   J = -H
740   T = (1.,0.)
      I = H + 1
      H = H + M
      G = J + O
      DO 750 K = I,H
750        A(K) =  (0.,0.)
760   DO 770 K = I,H
770        A(K) = A(K) + T*W(J+K)
      T = T*S
      J = J + M
      IF ( J .LT. G ) GOTO 760
      J = J - M
      S = S*V
      IF ( J+H .LT. N ) GOTO 740
      IF ( H .LT. N ) GOTO 730
      F = 0
      GOTO 10
780   J = -H
790   T = (1.,0.)
      I = H + 1
      E = I + 1
      D = E + 1
      H = H + M
      G = J + O
      A(I) = (0.,0.)
      A(E) = (0.,0.)
      A(D) = (0.,0.)
      A(H) = (0.,0.)
800   A(I) = A(I) + T*W(J+I)
      A(E) = A(E) + T*W(J+E)
      A(D) = A(D) + T*W(J+D)
      A(H) = A(H) + T*W(J+H)
      T = T*S
      J = J + M
      IF ( J .LT. G ) GOTO 800
      J = J - M
      S = S*V
      IF ( J+H .LT. N ) GOTO 790
      IF ( H .LT. N ) GOTO 780
      F = 0
      GOTO 10
810   J = -H
820   T = (1.,0.)
      I = H + 1
      E = I + 1
      H = H + M
      G = J + O
      A(I) = (0.,0.)
      A(E) = (0.,0.)
      A(H) = (0.,0.)
830   A(I) = A(I) + T*W(J+I)
      A(E) = A(E) + T*W(J+E)
      A(H) = A(H) + T*W(J+H)
      T = T*S
      J = J + M
      IF ( J .LT. G ) GOTO 830
      J = J - M
      S = S*V
      IF ( J+H .LT. N ) GOTO 820
      IF ( H .LT. N ) GOTO 810
      F = 0
      GOTO 10
840   J = -H
850   T = (1.,0.)
      I = H + 1
      H = H + M
      G = J + O
      A(I) = (0.,0.)
      A(H) = (0.,0.)
860   A(I) = A(I) + T*W(J+I)
      A(H) = A(H) + T*W(J+H)
      T = T*S
      J = J + M
      IF ( J .LT. G ) GOTO 860
      J = J - M
      S = S*V
      IF ( J+H .LT. N ) GOTO 850
      IF ( H .LT. N ) GOTO 840
      F = 0
      GOTO 10
870   J = -H
880   T = (1.,0.)
      I = H + 1
      H = H + M
      G = J + O
      A(I) = (0.,0.)
890   A(I) = A(I) + T*W(J+I)
      T = T*S
      J = J + M
      IF ( J .LT. G ) GOTO 890
      J = J - M
      S = S*V
      IF ( J+H .LT. N ) GOTO 880
      IF ( H .LT. N ) GOTO 870
      F = 0
      GOTO 10
900   IF ( F .EQ. 0 ) RETURN
      DO 910 I = 1,N
910        A(I) = W(I)
      RETURN
      END


      DOUBLE PRECISION FUNCTION DT_BETREJ(Gam,Eta,Xmin,Xmax)

      IMPLICIT NONE
      DOUBLE PRECISION betmax , betxx , DT_RNDM , Eta , Gam , ONE ,
     &                 Xmax , Xmin , xx , yy
      SAVE

      INCLUDE 'inc/dtflka'

      PARAMETER (ONE=1.0D0)

      IF ( Xmin.GE.Xmax ) THEN

         IF ( LPRi.GT.4 ) WRITE (LOUt,99010) Xmin , Xmax
99010    FORMAT (1X,'DT_BETREJ:  XMIN<XMAX execution stopped ',2F10.5)
         STOP
      END IF

 100  xx = Xmin + (Xmax-Xmin)*DT_RNDM(Eta)
      betmax = Xmin**(Gam-ONE)*(ONE-Xmin)**(Eta-ONE)
      yy = betmax*DT_RNDM(xx)
      betxx = xx**(Gam-ONE)*(ONE-xx)**(Eta-ONE)
      IF ( yy.GT.betxx ) GOTO 100
      DT_BETREJ = xx

      END FUNCTION


      SUBROUTINE bcuint(y,y1,y2,y12,x1l,x1u,x2l,x2u,x1,x2,ansy,ansy1,
     *ansy2)
      REAL ansy,ansy1,ansy2,x1,x1l,x1u,x2,x2l,x2u,y(4),y1(4),y12(4),
     *y2(4)
CU    USES bcucof
      INTEGER i
      REAL t,u,c(4,4)
      call bcucof(y,y1,y2,y12,x1u-x1l,x2u-x2l,c)
      if(x1u.eq.x1l.or.x2u.eq.x2l)pause 'bad input in bcuint'
      t=(x1-x1l)/(x1u-x1l)
      u=(x2-x2l)/(x2u-x2l)
      ansy=0.
      ansy2=0.
      ansy1=0.
      do 11 i=4,1,-1
        ansy=t*ansy+((c(i,4)*u+c(i,3))*u+c(i,2))*u+c(i,1)
        ansy2=t*ansy2+(3.*c(i,4)*u+2.*c(i,3))*u+c(i,2)
        ansy1=u*ansy1+(3.*c(4,i)*t+2.*c(3,i))*t+c(2,i)
11    continue
      ansy1=ansy1/(x1u-x1l)
      ansy2=ansy2/(x2u-x2l)
      return
      END

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


      subroutine  coord
c
c     ******************************************************************
c     *                                                                *
c     *   coordinate stretching functions                              *
c     *                                                                *
c     ******************************************************************
c
      use dims
c
c     ******************************************************************
c
      use geo_var
c
c     ******************************************************************
c
      use geo_param
c
c     ******************************************************************
c
      implicit none
c
c     ******************************************************************
c
c     local variables
c
c     ******************************************************************
c
      integer  :: i,j,ile
c
c     ******************************************************************
c
      real     :: pi
      real     :: dx,dy
      real     :: a,b,c,d
      real     :: px,bp
      real     :: a2,a3
c
c     ******************************************************************
c
      ile       = il/2  +1

      pi        = 4.*atan(1.)

      xlim      = xte*boundx
      dx        = 2.*boundx/float(il  -1)

      px        = pi/xlim
      bp        = bunch/px

      a2        = 3.*ylim1  -4.*ylim2
      a3        = 2.*ylim1  -3.*ylim2

      do i=1,il

      d         = float(i  -ile)*dx
      if (abs(d).le.xlim) d = d  +bp*sin(px*d)

      if (abs(d).gt.xlim) then
         b         = 1.
         if (d.lt.0.) b = -1.
         a         = 1.  -((d  -b*xlim)/(1.  -xlim))**2
         c         = a**ax
         d         = b*xlim  +(1.  -bunch)*(d  -b*xlim)/c
      end if

      a0(i)     = d

      d         = abs(d/xlim)
      if (d.ge.1.) then
         a1(i)     = ylim2*xlim/abs(a0(i))
      else
         a1(i)     = ylim1  -d*d*(a2  -a3*d)
      end if

c     a1(i)     = 1.

      d         = a0(i)*a1(i)
      write (6,1006) i,a0(i),a1(i),d
 1006 format(1x,'i',i6,2x,'a0,a1,d',3f12.4)

      end do

      dy        = boundy/float(jl  -1)

      do j=1,jl

      d         = float(j  -1)*dy
      a         = 1.  -d*d
      c         = a**ay
      b0(j)     = sy*d/c

      end do

      return

      end


c=======================================================================
c
c
c     Fichier d'utilitaires
c
c     sous-programmes specifiques allocation avec "turn-over"
c
c        CTMVT   : computing constraints for ALLOCMVT
c                  Mean Variance ALLOCation (Markowitz)
c                  with Turn-over minimization
c
c        OPMVT   : computing optimization for ALLOCMVT
c                  Mean Variance ALLOCation (Markowitz)
c                  with Turn-over minimization
c
c        OPVART  : computing optimization for ALLOCVART
c                  optimal ALLOCation and VAlue at Risk
c                  with Turn-over minimization
c
c=======================================================================
c
c     subroutine CTMVT
c
c     Computing constraints for ALLOCMVT
c               Mean Variance ALLOCation (Markowitz)
c               with Turn-over minimization
c
c=======================================================================
c
c     INPUT :
c            nasset : size of portfolio                          integer
c            winit  : initial portfolio, vector(nasset)           double
c            rmean  : mean returns vector(nasset)                 double
c            wgcf   : weight of guarantied capital fund
c            rgcf   : return of guarantied capital fund
c            mu     : performance target                          double
c            tomax  : turn-over maxi                              double
c            neq    : number of initial equality constraints     integer
c            nin    : number of initial inequality constraints   integer
c            ccst   : matrix initial of constraints
c                     matrix (nasset*(neq+nin))                   double
c            bcst   : vector(neq+nin) initial of constraints      double
c
c     OUTPUT :
c            neqtot : number of equality constraints             integer
c            nintot : number of inequality constraints           integer
c            ccstot : matrix of constraints                       double
c                     matrix((nasset+nasset)*nctot)
c            bcstot : vector of constraints                       double
c                     vector( neq + nin + 2*nasset + 3 )
c            plin   : linear part vector(nasset+nasset)           double
c
c     METHOD :
c                 composition of ccstot, bcstot, plin
c         - ccstot
c           | 1 | 1 | neq   |   nin   | nasset  |  nasset | 1 |  size
c           ___________________________________________________
c           |   |   |                 |         |         | - |
c           |   |   |                 |         |         | r |
c           |   |   |                 |         |         | m |
c           | 1 | 0 |      ccst       |    Id   |   -Id   | e |  nasset
c           |   |   |                 |         |         | a |  ( w(i) )
c           |   |   |                 |         |         | n |
c           |   |   |                 |         |         |   |
c           ___________________________________________________
c           |   |   |                 |         |         |   |
c           |   |   |                 |         |         |   |
c           |   |   |                 |         |         |   |
c           | 0 | 1 |       0         |   -Id   |   -Id   | 0 |  nasset
c           |   |   |                 |         |         |   |  ( u(i) )
c           |   |   |                 |         |         |   |
c           |   |   |                 |         |         |   |
c           ___________________________________________________
c
c         - bcstot
c           | 1 | 1 | neq   |   nin   | nasset  |  nasset | 1 |  size
c           ___________________________________________________
c           |1-w|tom|      bcst       | winit   |  -winit |-mu|   1
c           |   |   |                 |         |         |+rw|
c           ___________________________________________________
c
c         - plin
c           |          nasset       |        nasset         |  size
c           _________________________________________________
c           |            0          |          0            |   1
c           _________________________________________________
c
c-----------------------------------------------------------------------
c
      subroutine CTMVT ( nasset, winit, rmean, wgcf, rgcf,
     &                   mu, tomax,
     &                   neq, nin, ccst, bcst,
     &                   neqtot, nintot, ccstot, bcstot, plin )
c
      implicit none
c
      integer nasset, neq, nin, neqtot, nintot
      double precision wgcf, rgcf, mu, tomax
      double precision winit(*), rmean(*), bcst(*), bcstot(*), plin(*)
      double precision ccst(nasset,*), ccstot(2*nasset,*)
c
      integer i, j, nopt, nctot, ncini
      integer pjsum, pjto, pjc, pjw, pjmw, pjr, piw, piu
c
c-----------------------------------------------------------------------
c
c     initialisations
c
      ncini = neq + nin
      nopt = nasset + nasset
      neqtot = neq + 2
      nintot = nin + 2*nasset + 1
      nctot = neqtot + nintot
c
c     construction of the linear part
c
      do i=1,nopt
         plin(i) = 0.
      end do
c
c     pointers for construction of constraints matrix
c
      piw = 1
      piu = piw + nasset
c
      pjsum = 1
      pjto = pjsum + 1
      pjc = pjto + 1
      pjw = pjc + ncini
      pjmw = pjw + nasset
      pjr = pjmw + nasset
c
c     construction of the constraints matrix
c
      do i=1,nasset
c
         ccstot(piw+i-1,pjsum) = 1.0
         ccstot(piu+i-1,pjsum) = 0.0
c
         ccstot(piw+i-1,pjto) = 0.0
         ccstot(piu+i-1,pjto) = 1.0
c
         do j=1,ncini
            ccstot(piw+i-1,pjc+j-1) = ccst(i,j)
            ccstot(piu+i-1,pjc+j-1) = 0.0
         end do
c
         do j=1,nasset
            if (i.eq.j) then
               ccstot(piw+i-1,pjw+j-1) = 1.0
               ccstot(piu+i-1,pjw+j-1) = -1.0
               ccstot(piw+i-1,pjmw+j-1) = -1.0
               ccstot(piu+i-1,pjmw+j-1) = -1.0
            else
               ccstot(piw+i-1,pjw+j-1) = 0.0
               ccstot(piu+i-1,pjw+j-1) = 0.0
               ccstot(piw+i-1,pjmw+j-1) = 0.0
               ccstot(piu+i-1,pjmw+j-1) = 0.0
            end if
         end do
c
         ccstot(piw+i-1,pjr) = - rmean(i)
         ccstot(piu+i-1,pjr) = 0.0
c
      end do
c
c     construction of the constraints vector
c
      bcstot(pjsum) = 1.0 - wgcf
      bcstot(pjto) = 2.*tomax
c
      do j=1,ncini
         bcstot(pjc+j-1) = bcst(j)
      end do
      do j=1,nasset
         bcstot(pjw+j-1) = winit(j)
         bcstot(pjmw+j-1) = -winit(j)
      end do
      bcstot(pjr) = - mu + wgcf*rgcf
      bcstot(pjto) = 2.*tomax
c
      return
      end
c
c=======================================================================
c=======================================================================
c
c     subroutine OPMVT
c
c     Computing optimization for ALLOCMVT
c               Mean Variance ALLOCation (Markowitz)
c               with Turn-over minimization
c
c=======================================================================
c
c     INPUT :
c            nasset : number of risky assets                     integer
c            winit  : initial portfolio, vector(nasset+1)         double
c                     guarantied capital fund in first
c            cov    : covariance matrix(nasset*nasset)            double
c            rmean  : mean returns, vector(nasset)                double
c            rgcf   : return of guarantied capital fund
c            mu     : performance target                          double
c            tomax  : turn-over maxi (0<tomax<1)                  double
c            neq    : number of initial equality constraints     integer
c            nin    : number of initial inequality constraints   integer
c            ccst   : matrix initial of constraints
c                     matrix (nasset*(neq+nin))                   double
c            bcst   : vector(neq+nin) initial of constraints      double
c            cinf   : assets inferior limit, vector (nasset)      double
c            csup   : assets superior limit, vector (nasset)      double
c
c     WORKSPACE :
c            iwork  : vector( 10*nasset + 2*nin + neq + 6 )      integer
c            dwork  : matrix                                      double
c                     (  nasset*( 12*nasset + 2*neq + 2*nin + 36 )
c                        + 3*neq + 5*nin + 10  )
c
c     OUTPUT :
c            wopt   : optimal portfolio  vector(nasset+1)         double
c                     guarantied capital fund in first
c            info   : = 0 successful exit                        integer
c                     = 5 : bad value for tomax
c                     = 6 : max of iterations on alpha exceeded
c
c     CALL   :
c        TM      : computing the trace of a full matrix
c        IVX     : initialization at a scalar of a vector
c        YM      : copy a matrix in a matrix
c        YV      : copy a vector in a vector
c        OPMV    : computing optimization for ALLOCMV
c        NDVL1   : computing the L_1 norm of the difference of 2 vectors
c        IMX     : initialization at a scalar of a matrix
c        YMPMP   : copy a part of a vectorized matrix
c                  in a part of a vectorized matrix
c        CTMVT   : Computing constraints for ALLOCMVT
c        QUAPRO  : quadratic solver (vectorized version)
c
c-----------------------------------------------------------------------
c
      subroutine OPMVT ( nasset, winit, cov, rmean, rgcf, mu, tomax,
     &                   neq, nin, ccst, bcst, cinf, csup,
     &                   iwork, dwork, wopt, info )
c
      implicit none
c
      integer nasset, info, neq, nin
      double precision mu, tomax, rgcf
      double precision cov(*), winit(*), rmean(*), cinf(*), csup(*)
      double precision ccst(nasset,*), bcst(*), wopt(*)
c
      integer iwork(*)
      double precision dwork(*)
c
      integer nopt, neqtot, nintot, nctot, ncini, neqop, ncop
      integer pdbop, pdcop
      integer pdcov, pdvopt, pdinf, pdsup, pdlin, pdlagr, pdbcs, pdccs
      integer piwo, pdwo, piwq, pdwq
      double precision tomes, wgcf, mugcf
      double precision myzero, dzero, dun
c
      parameter ( myzero = 1.0d-12 )
      parameter ( dzero = 0.0d0, dun = 1.0d0 )
c
c-----------------------------------------------------------------------
c
c     initialisations
      ncini = neq + nin
      neqop = neq + 1
      ncop = neqop + nin
      nopt = nasset + nasset
      neqtot = neq + 2
      nintot = nin + 2*nasset + 1
      nctot = neqtot + nintot
c
c     --- pointers for integer work space : iwork ---
c
      piwo = 1
c     piwo  : pointer for internal workspaces of OPMV
c             needs ( 3*nasset + 2*nin + neqop + 3 )
c             with neqop = neq + 1
c        = ( 3*nasset + 2*nin + (neq+1) + 3 )
c        = ( 3*nasset + 2*nin + neq + 4 )
      piwq = 1
c     piwq  : pointer for internal workspaces of QUAPRO
c             needs ( 3*nopt + 2*nintot + neqtot + 1 ),
c             with nopt = 2*nasset
c                neqtot = neq + 1
c                nintot = nin + 2*nasset + 2
c        = 6*nasset + 2*(nin + 2*nasset + 2) + (neq + 1) + 1 )
c        = 6*nasset + 2*nin + 4*nasset + 4 + neq + 2 )
c        = ( 10*nasset + 2*nin + neq + 6 )
c
c     together OPVM and QUAPRO need (union of space) :
c        ( 10*nasset + 2*nin + neq + 6 )
c
c     size of iwork array = ( 10*nasset + 2*nin + neq + 6 )
c
c     --- pointers for double precision work space  : dwork ---
c
c     pointers for the call of OPMV
      pdbop  = 1
c     pdbop  : pointer for the constraints vector( ncop ),
      pdcop  = pdbop + ( ncop )
c     pdcop  : pointer for the constraints matrix( nasset*ncop ),
      pdwo   = pdcop + ( nasset*ncop )
c     pdwo   : pointer for internal workspace of OPMV
c              needs(  nasset*( nasset + neqop + nin + 9 ) +
c                      2*neqop + 4*nin + 4  )
c     size of dwork array need by the call of OPMV:
c                     ncop + nasset*ncop +
c                     nasset*( nasset + neqop + nin + 9 ) +
c                     2*neqop + 4*nin + 4
c
c     with ncop = neqop + nin
c
c                   = neqop + nin + nasset*( neqop + nin ) +
c                     nasset*( nasset + neqop + nin + 9 ) +
c                     2*neqop + 4*nin + 4
c                   = nasset*( nasset + 2*neqop + 2*nin + 9 ) +
c                     3*neqop + 5*nin + 4
c
c     with neqop = neq + 1
c
c                   = nasset*( nasset + 2*neq + 2*nin + 11 ) +
c                     3*neq + 5*nin + 7
c
c     pointers for the call of QUAPRO who uses a part of the same space
c     than OPMV
      pdcov  = 1
c     pdcov  : pointer for covariance matrix( nopt*nopt ) to minimize
      pdvopt = pdcov + ( nopt*nopt )
c     pdvopt : pointer for vector( nopt ) to optimize
      pdlin  = pdvopt + ( nopt )
c     pdlin  : pointer for linear part, vector( nopt )
      pdinf  = pdlin + ( nopt )
c     pdinf  : pointer for inferior limit, vector( nopt )
      pdsup  = pdinf + ( nopt )
c     pdsup  : pointer for superior limit, vector( nopt )
      pdbcs  = pdsup + ( nopt )
c     pdbcs  : pointer for the constraints vector( nctot ),
      pdccs  = pdbcs + ( nctot )
c     pdccs  : pointer for the constraints matrix( nopt*nctot ),
      pdlagr = pdccs + ( nopt*nctot )
c     pdlagr : pointer for Lagrange multipliers vector( nopt + nctot )
      pdwq   = pdlagr + ( nopt + nctot )
c     pdwq   : pointer for QUAPRO internal workspace,
c              (nopt*nopt + 6*nopt + 2*nintot),
c     size of dwork array need by the call of QUAPRO:
c                     ( nopt*nopt ) + 4*nopt + nctot +
c                     ( nopt *( nctot ) ) + ( nopt + nctot ) +
c                     (nopt*nopt + 6*nopt + 2*nintot)
c                   = 2*( nopt*nopt ) + nopt *( nctot ) +
c                     11*nopt + 2*nctot + 2*nintot
c
c     with nctot = neqtot + nintot
c
c                   = 2*( nopt*nopt ) + nopt *( neqtot + nintot ) +
c                     11*nopt + 2*(neqtot + nintot) + 2*nintot
c                   = 2*( nopt*nopt ) + nopt *( neqtot + nintot ) +
c                     11*nopt + 2*neqtot + 4*nintot
c
c     with nopt   = 2*nasset
c          neqtot = neq + 1
c          nintot = nin + 2*nasset + 2
c
c                   = 8*( nasset*nasset ) +
c                     2*nasset*( neq + 1 + nin + 2*nasset + 2 ) +
c                     22*nasset + 2*neq + 2 + 4*(nin + 2*nasset + 2)
c                   = 8*( nasset*nasset ) +
c                     4*( nasset*nasset ) +
c                     nasset*( 2*neq + 2*nin + 6 ) +
c                     22*nasset + 2*neq + 4*nin + 8*nasset + 10
c                   = nasset*( 12*nasset + 2*neq + 2*nin + 36 ) +
c                     2*neq + 4*nin + 10
c
c     together OPVM and QUAPRO need (union of space) :
c        (  nasset*( 12*nasset + 2*neq + 2*nin + 36 ) +
c                     3*neq + 5*nin + 10  )
c
c     size of dwork array =
c        (  nasset*( 12*nasset + 2*neq + 2*nin + 36 ) +
c           3*neq + 5*nin + 10  )
c
c.......................................................................
c
c     initial computing
c
c.......................................................................
c
c     computing guarantied capital fund
c
      wgcf = winit(1)
      wopt(1) = wgcf
      mugcf = mu-wgcf*rgcf
c
c.......................................................................
c
c     optimization without turn-over constraint
c
c.......................................................................
c
c     construction of the equal constraint : SUM(w(i)) = 1-wgcf
c
      call IVX ( nasset, dwork(pdcop), dun )
      call YM ( nasset, ncini, ccst, dwork(pdcop+nasset) )
      dwork(pdbop) = 1. - wgcf
      call YV ( ncini, bcst, dwork(pdbop+1) )
c
c     optimization
      call OPMV ( nasset, cov, rmean, mugcf,
     &            neqop, nin, dwork(pdcop), dwork(pdbop), cinf, csup,
     &            iwork(piwo), dwork(pdwo), wopt(2), info )
      if(info.ne.0) return
c
c     computing turn-over
      call NDVL1 ( nasset+1, winit, wopt, tomes )
c
c     optimization with turn-over constraint
      if (2.*tomax.lt.tomes) then
c
c        construction of covariance matrix
         call IMX ( nopt, nopt, dwork(pdcov), dzero )
         call YMPMP ( nasset, nasset, nasset, nasset, cov, 1, 1,
     &                nopt, nopt, dwork(pdcov), 1, 1, info )
c        info = 0 by construction
c
c        construction of the bounds and initial vector
         call IVX ( nopt, dwork(pdinf), dzero )
         call IVX ( nopt, dwork(pdsup), dun )
         call IVX ( nopt, dwork(pdvopt), dzero )
         call YV ( nasset, cinf, dwork(pdinf) )
         call YV ( nasset, csup, dwork(pdsup) )
c
c        construction of the constraints matrix and vector,
c        and initial linear part
         call CTMVT ( nasset, winit(2), rmean, wgcf, rgcf,
     &                mu, tomax,
     &                neq, nin, ccst, bcst, neqtot, nintot,
     &                dwork(pdccs), dwork(pdbcs), dwork(pdlin) )
c
c        quadratic solver QUAPRO
         call QUAPRO ( nopt, dwork(pdcov), dwork(pdlin),
     &                 dwork(pdccs), dwork(pdbcs),
     &                 dwork(pdinf), dwork(pdsup),
     &                 neqtot, nintot, iwork(piwq), dwork(pdwq),
     &                 dwork(pdlagr), dwork(pdvopt), info )
         if(info.ne.0) return
c
c        vector solution
         call YV ( nasset, dwork(pdvopt), wopt(2) )
c
      end if
c
      return
      end
c
c=======================================================================
c=======================================================================
c
c     subroutine OPVART
c
c     Computing optimization for ALLOCVART
c               optimal ALLOCation and VAlue at Risk
c               with Turn-over minimization
c
c=======================================================================
c=======================================================================
c
c     INPUT :
c            nasset : number of assets                           integer
c            winit  : initial portfolio, vector(nasset+1)         double
c                     guarantied capital fund in first
c            cov    : covariance matrix (nasset*nasset)           double
c            rmean  : mean returns vector (nasset)                double
c            rgcf   : return of guarantied capital fund
c            neq    : number of initial equality constraints     integer
c            nin    : number of initial inequality constraints   integer
c            ccst   : matrix of constraints
c                     matrix(nasset*(neq+nin))                    double
c            bcst   : vector of constraints  vector(neq+nin)      double
c            cinf   : assets inferior limit  vector (nasset)      double
c            csup   : assets superior limit  vector (nasset)      double
c            tomax  : turn-over maxi (0<tomax<1)                  double
c            vrimax : maximum value at risk                       double
c            conflp : confidence level parameter ( 0<conflp<1 )   double
c            maxdic : maximum of dichotomy iterations            integer
c            epsdic : precision of dichotomy                      double
c
c     WORKSPACE :
c            iwork  : vector ( 10*nasset + 2*nin + neq + 6 )     integer
c            dwork  : matrix                                      double
c                    (  nasset*(12*nasset+2*neq+2*nin+38) +
c                       3*neq + 5*nin + 11  )
c
c     OUTPUT :
c            wopt   : optimal portfolio  vector(nasset+1)         double
c                     guarantied capital fund in first
c            vriopt : optimal value at risk                       double
c            info   : = 0 successful exit                        integer
c                     = 5    : bad value for tomax
c                     = -1   : no solution for vriopt < vrimax
c                     = -5   : not ( 0<conflp<1 )
c                     = -12  : no solution with these constraints
c                     =  1   : solution non-optimal, reach maxdic
c
c     CALL   :
c        EVBOR   : computing the minimum and maximum of a vector
c        OPMVT   : computing optimization for ALLOCMVT
c        WZERO   : put zero at the values of a vector less than eps
c                  and increase the greatest element with residual
c        YV      : copy a vector in a vector
c        XV      : computing scalar product of two vectors = V1'*V2
c        OVTMCV  : computing V'*M*V = scalar
c                  ( M vectorized square matrix(n*n), V vector(n) )
c
c-----------------------------------------------------------------------
c
      subroutine OPVART ( nasset, winit, cov, rmean, rgcf,
     &                    neq, nin, ccst, bcst, cinf, csup, tomax,
     &                    vrimax, conflp, maxdic, epsdic,
     &                    iwork, dwork,
     &                    wopt, vriopt, info )
c
      implicit none
c
      integer nasset, neq, nin, maxdic, info
c
      double precision rgcf, tomax, vrimax, conflp, epsdic
      double precision vriopt
      double precision cov(*), winit(*), rmean(*), cinf(*), csup(*)
      double precision ccst(*), bcst(*), wopt(*)
c
      integer iwork(*)
      double precision dwork(*)
c
      integer niter, infmax, infqua, i
      integer piwo, pdwopt, pdmean, pdwo
c
      double precision rhopt, emret, volat, varian, proba, vrisav
      double precision rhomin, rhomax, epsvri, xvri, myzero
c
      parameter ( myzero = 1.0d-12 )
c
c-----------------------------------------------------------------------
c
c     initializations
      info = 0
c
c     --- pointers for integer work space : iwork ---
c
      piwo = 1
c     piwo  : pointer for internal workspaces of OPMVT
c             needs ( 10*nasset + 2*nin + neq + 6 )
c
c             so size of iwork array = ( 10*nasset + 2*nin + neq + 6 )
c
c     --- pointers for double precision work space  : dwork ---
c
      pdmean = 1
c     pdmean : pointer for rmean used to compute VaR, vector(nasset)
      pdwopt = pdmean + ( nasset )
c     pdwopt : pointer for wopt save vector(nasset+1)
      pdwo   = pdwopt + ( nasset+1 )
c     pdwo   : pointer for internal workspace of OPMVT
c               needs(  nasset*( 12*nasset + 2*neq + 2*nin + 36 ) +
c                       3*neq + 5*nin + 10  )
c
c     so size of dwork array = (nasset) + (nasset+1) +
c                nasset*(12*nasset+2*neq+2*nin+36) + 3*neq + 5*nin + 10
c
c        = nasset*(12*nasset+2*neq+2*nin+38) + 3*neq + 5*nin + 11
c
c.......................................................................
c
c     inputs control
      if ( (conflp.le.myzero) .or. (conflp.ge.(1.-myzero)) ) then
         info = -5
         return
      end if
c
c     computing rhomin and rhomax
      call EVBOR ( nasset, rmean, rhomin, rhomax )
c
c     computing rmean =<0.to compute the VaR
      do i=1,nasset
         if (rmean(i).gt.0.) then
            dwork(pdmean+i-1) = 0.
         else
            dwork(pdmean+i-1) = rmean(i)
         end if
      end do
c
c.......................................................................
c
c     research of optimal value at risk by dichotomy
c
c.......................................................................
c
c     initializations
      vrisav = 0.
      xvri = 0.0
      rhopt = rhomax
      epsvri = 2.*epsdic
      vriopt = -1.
      infmax = -1
      infqua = 0
      niter = 0
c
      do while ( ( (niter.le.maxdic).and.(epsvri.gt.epsdic) ) .and.
     &           ( (xvri.gt.vrimax).or.(niter.ne.1) ) )
c
         niter = niter + 1
c
c        optimization ( ALLOCMVT )
         call OPMVT ( nasset, winit, cov,
     &                rmean, rgcf, rhopt, tomax,
     &                neq, nin, ccst, bcst, cinf, csup,
     &                iwork(piwo), dwork(pdwo), wopt, info )
c
c        put zero at the values of a wopt less than myzero
c        and increase the great element with residual
         call WZERO ( nasset, wopt(2), myzero )
c
c        errors gestion
         if(info.ne.0) then
            if(info.ne.-12) then
               return
            else
               infqua = - 12
            end if
         else
            infqua = 0
            call YV ( nasset+1, wopt, dwork(pdwopt) )
         end if
c
c        computing variance = w'*Cov*w
         call OVTMCV ( nasset, cov, wopt(2), varian )
c
c        computing ex-ante return = w'*rmean
         call XV ( nasset, wopt(2), dwork(pdmean), emret )
c
c        computing value at risk
         volat = sqrt(varian)
         proba = volat * sqrt( conflp/(1.-conflp) ) - emret
         xvri = min(proba,1.)
         xvri = max(xvri,0.)
c
c        saving last good result
         if(infqua.eq.0) then
            vrisav = xvri
         else
            if(niter.eq.1) then
               vrisav = xvri
               call YV ( nasset+1, wopt, dwork(pdwopt) )
               infqua = 0
               info = 0
            end if
         end if
c
c        computing stop test
         epsvri = abs(xvri-vriopt)
         vriopt = xvri
c
c        dichotomy
         if (vriopt.lt.vrimax) then
            rhomin = rhopt
            infmax = 0
         else
            rhomax = rhopt
         end if
         rhopt = ( rhomax + rhomin ) / 2.
      end do
c
c.......................................................................
c
c     gestion of output
c
c.......................................................................
c
      if (niter.gt.maxdic) info = 1
      if(infmax.ne.0) info = infmax
      if(infqua.ne.0) then
         info = infqua
         call YV ( nasset+1, dwork(pdwopt), wopt )
         vriopt = vrisav
      end if
c
      return
      end


!=============================================================================!
        subroutine cgrad( ndof, nx, ny, v, g1v, g2v, dx, dy, optx, opty, &
                          xper, yper, lsym, rsym, bsym, tsym, carp)
!
!  Take the gradient of a complex 2-D field.
!  Updated to sixth-order accurate differencing on the interior with
!  the option for optimized fourth-order differencing.
!
!  Revised: 4-17-96
!=============================================================================!
        use diff
        implicit none

        integer :: ndof, nx, ny, optx, opty
        logical :: xper, yper
        logical :: lsym, rsym, bsym, tsym, carp
        complex :: v(ny,nx,ndof), g1v(ny,nx,ndof), g2v(ny,nx,ndof)
        real    :: dx, dy

        real, parameter :: zero = 0.0, one = 1.0, pt5 = 0.5
        real dxinv, dyinv
        real a, b, c, w
        real gx1, gx2, gx3, gx4, gx5, gx6
        real gy1, gy2, gy3, gy4, gy5, gy6

        integer :: i, j, idof
        real :: eps = 1.0e-12, isign
!=============================================================================!
        dxinv  = one / dx
        dyinv  = one / dy

!.... seven point stencil in x

        if (optx.eq.0) then
          c = 1.0 / 60.0
        else if (optx.eq.-1) then
          c = 0.0
        else
          w = 2.0 * 3.1415926535897932385e+0 / 12.0
          c = (w/2.0 - 2.0*Sin(w)/3.0 + Sin(2.0*w)/12.0) / &
              (5.0*Sin(w) - 4.0*Sin(2.0*w) + Sin(3.0*w))
        end if

        a = (2.0 + 15.0 * c) / 3.0
        b = -(1.0 + 48.0 * c) / 12.0

        gx1 =  -c * dxinv
        gx2 =  -b * dxinv
        gx3 =  -a * dxinv
        gx4 =   a * dxinv
        gx5 =   b * dxinv
        gx6 =   c * dxinv

!.... seven point stencil in y

        if (opty.eq.0) then
          c = 1.0 / 60.0
        else if (opty.eq.-1) then
          c = 0.0
        else
          w = 2.0 * 3.1415926535897932385e+0 / 12.0
          c = (w/2.0 - 2.0*Sin(w)/3.0 + Sin(2.0*w)/12.0) / &
              (5.0*Sin(w) - 4.0*Sin(2.0*w) + Sin(3.0*w))
        end if

        a = (2.0 + 15.0 * c) / 3.0
        b = -(1.0 + 48.0 * c) / 12.0

        gy1 =  -c * dyinv
        gy2 =  -b * dyinv
        gy3 =  -a * dyinv
        gy4 =   a * dyinv
        gy5 =   b * dyinv
        gy6 =   c * dyinv

!=============================================================================!
!.... compute the gradient in x
!=============================================================================!

        if (xper) then

          g1v(:,1,:)        = ( gx1 * v(:,nx-3,:)       + &
                                gx2 * v(:,nx-2,:)       + &
                                gx3 * v(:,nx-1,:)       + &
                                gx4 * v(:,2,:)          + &
                                gx5 * v(:,3,:)          + &
                                gx6 * v(:,4,:)  )

          g1v(:,2,:)        = ( gx1 * v(:,nx-2,:)       + &
                                gx2 * v(:,nx-1,:)       + &
                                gx3 * v(:,1,:)          + &
                                gx4 * v(:,3,:)          + &
                                gx5 * v(:,4,:)          + &
                                gx6 * v(:,5,:)  )

          g1v(:,3,:)        = ( gx1 * v(:,nx-1,:)       + &
                                gx2 * v(:,1,:)          + &
                                gx3 * v(:,2,:)          + &
                                gx4 * v(:,4,:)          + &
                                gx5 * v(:,5,:)          + &
                                gx6 * v(:,6,:)  )

          g1v(:,nx-2,:)     = ( gx1 * v(:,nx-5,:)       + &
                                gx2 * v(:,nx-4,:)       + &
                                gx3 * v(:,nx-3,:)       + &
                                gx4 * v(:,nx-1,:)       + &
                                gx5 * v(:,1,:)          + &
                                gx6 * v(:,2,:)  )

          g1v(:,nx-1,:)     = ( gx1 * v(:,nx-4,:)       + &
                                gx2 * v(:,nx-3,:)       + &
                                gx3 * v(:,nx-2,:)       + &
                                gx4 * v(:,1,:)          + &
                                gx5 * v(:,2,:)          + &
                                gx6 * v(:,3,:)  )

          g1v(:,nx,:) = g1v(:,1,:)

        else

          g1v(:,1,:)      = ( gc1 * v(:,1,:)  + &
                              gc2 * v(:,2,:)  + &
                              gc3 * v(:,3,:)  + &
                              gc4 * v(:,4,:)  + &
                              gc5 * v(:,5,:)  ) * dxinv

          g1v(:,2,:)      = ( gb1 * v(:,1,:)  + &
                              gb2 * v(:,2,:)  + &
                              gb3 * v(:,3,:)  + &
                              gb4 * v(:,4,:)  + &
                              gb5 * v(:,5,:)  ) * dxinv

          g1v(:,3,:)      = ( ga1 * v(:,1,:)  + &
                              ga2 * v(:,2,:)  + &
                              ga3 * v(:,4,:)  + &
                              ga4 * v(:,5,:)  ) * dxinv

          g1v(:,nx-2,:)   = ( ga1 * v(:,nx-4,:)  + &
                              ga2 * v(:,nx-3,:)  + &
                              ga3 * v(:,nx-1,:)  + &
                              ga4 * v(:,nx  ,:)  ) * dxinv

          g1v(:,nx-1,:)  = -( gb1 * v(:,nx  ,:)  + &
                              gb2 * v(:,nx-1,:)  + &
                              gb3 * v(:,nx-2,:)  + &
                              gb4 * v(:,nx-3,:)  + &
                              gb5 * v(:,nx-4,:)  ) * dxinv

          g1v(:,nx,:)    = -( gc1 * v(:,nx  ,:)  + &
                              gc2 * v(:,nx-1,:)  + &
                              gc3 * v(:,nx-2,:)  + &
                              gc4 * v(:,nx-3,:)  + &
                              gc5 * v(:,nx-4,:)  ) * dxinv

        end if

!.... implement the symmetric conditions

        if (lsym) then
          do idof = 1, ndof
            if (idof .eq. 3) then
              isign = -one
            else
              isign = one
            end if

            g1v(:,1,idof)     = ( isign * gx1 * v(:,4,idof)     + &
                                  isign * gx2 * v(:,3,idof)     + &
                                  isign * gx3 * v(:,2,idof)     + &
                                  gx4 * v(:,2,idof)             + &
                                  gx5 * v(:,3,idof)             + &
                                  gx6 * v(:,4,idof)             )

            g1v(:,2,idof)     = ( isign * gx1 * v(:,3,idof)     + &
                                  isign * gx2 * v(:,2,idof)     + &
                                  gx3 * v(:,1,idof)             + &
                                  gx4 * v(:,3,idof)             + &
                                  gx5 * v(:,4,idof)             + &
                                  gx6 * v(:,5,idof)             )

            g1v(:,3,idof)     = ( isign * gx1 * v(:,2,idof)     + &
                                  gx2 * v(:,1,idof)             + &
                                  gx3 * v(:,2,idof)             + &
                                  gx4 * v(:,4,idof)             + &
                                  gx5 * v(:,5,idof)             + &
                                  gx6 * v(:,6,idof)             )
          end do
        end if

        if (rsym) then
          do idof = 1, ndof
            if (idof .eq. 3) then
              isign = -one
            else
              isign = one
            end if

            g1v(:,nx-2,idof)  = ( gx1 * v(:,nx-5,idof)          + &
                                  gx2 * v(:,nx-4,idof)          + &
                                  gx3 * v(:,nx-3,idof)          + &
                                  gx4 * v(:,nx-1,idof)          + &
                                  gx5 * v(:,nx,idof)            + &
                                  isign * gx6 * v(:,nx-1,idof)          )

            g1v(:,nx-1,idof)  = ( gx1 * v(:,nx-4,idof)          + &
                                  gx2 * v(:,nx-3,idof)          + &
                                  gx3 * v(:,nx-2,idof)          + &
                                  gx4 * v(:,nx,idof)            + &
                                  isign * gx5 * v(:,nx-1,idof)  + &
                                  isign * gx6 * v(:,nx-2,idof)  )

            g1v(:,nx,idof)    = ( gx1 * v(:,nx-3,idof)          + &
                                  gx2 * v(:,nx-2,idof)          + &
                                  gx3 * v(:,nx-1,idof)          + &
                                  isign * gx4 * v(:,nx-1,idof)  + &
                                  isign * gx5 * v(:,nx-2,idof)  + &
                                  isign * gx6 * v(:,nx-3,idof)  )
          end do
        end if

!.... interior

        g1v(:,4:nx-3,:)  = ( gx1 * v(:,1:nx-6,:)        + &
                             gx2 * v(:,2:nx-5,:)        + &
                             gx3 * v(:,3:nx-4,:)        + &
                             gx4 * v(:,5:nx-2,:)        + &
                             gx5 * v(:,6:nx-1,:)        + &
                             gx6 * v(:,7:nx  ,:)        )

!=============================================================================!
!.... compute the gradient in y
!=============================================================================!

        if (yper) then

          g2v(1,:,:)        = ( gy1 * v(ny-3,:,:)       + &
                                gy2 * v(ny-2,:,:)       + &
                                gy3 * v(ny-1,:,:)       + &
                                gy4 * v(2,:,:)          + &
                                gy5 * v(3,:,:)          + &
                                gy6 * v(4,:,:)          )

          g2v(2,:,:)        = ( gy1 * v(ny-2,:,:)       + &
                                gy2 * v(ny-1,:,:)       + &
                                gy3 * v(1,:,:)          + &
                                gy4 * v(3,:,:)          + &
                                gy5 * v(4,:,:)          + &
                                gy6 * v(5,:,:)  )

          g2v(3,:,:)        = ( gy1 * v(ny-1,:,:)       + &
                                gy2 * v(1,:,:)          + &
                                gy3 * v(2,:,:)          + &
                                gy4 * v(4,:,:)          + &
                                gy5 * v(5,:,:)          + &
                                gy6 * v(6,:,:)  )

          g2v(ny-2,:,:)     = ( gy1 * v(ny-5,:,:)       + &
                                gy2 * v(ny-4,:,:)       + &
                                gy3 * v(ny-3,:,:)       + &
                                gy4 * v(ny-1,:,:)       + &
                                gy5 * v(1,:,:)          + &
                                gy6 * v(2,:,:)  )

          g2v(ny-1,:,:)     = ( gy1 * v(ny-4,:,:)       + &
                                gy2 * v(ny-3,:,:)       + &
                                gy3 * v(ny-2,:,:)       + &
                                gy4 * v(1,:,:)          + &
                                gy5 * v(2,:,:)          + &
                                gy6 * v(3,:,:)  )

          g2v(ny,:,:) = g2v(1,:,:)

        else

          g2v(1,:,:)     = ( gc1 * v(1,:,:)     + &
                             gc2 * v(2,:,:)     + &
                             gc3 * v(3,:,:)     + &
                             gc4 * v(4,:,:)     + &
                             gc5 * v(5,:,:)  ) * dyinv

          g2v(2,:,:)     = ( gb1 * v(1,:,:)     + &
                             gb2 * v(2,:,:)     + &
                             gb3 * v(3,:,:)     + &
                             gb4 * v(4,:,:)     + &
                             gb5 * v(5,:,:)  ) * dyinv

          g2v(3,:,:)     = ( ga1 * v(1,:,:)     + &
                             ga2 * v(2,:,:)     + &
                             ga3 * v(4,:,:)     + &
                             ga4 * v(5,:,:)  ) * dyinv

          g2v(ny-2,:,:)  = ( ga1 * v(ny-4,:,:)  + &
                             ga2 * v(ny-3,:,:)  + &
                             ga3 * v(ny-1,:,:)  + &
                             ga4 * v(ny  ,:,:)  ) * dyinv

          g2v(ny-1,:,:) = -( gb1 * v(ny  ,:,:)  + &
                             gb2 * v(ny-1,:,:)  + &
                             gb3 * v(ny-2,:,:)   + &
                             gb4 * v(ny-3,:,:)  + &
                             gb5 * v(ny-4,:,:)  ) * dyinv

          g2v(ny,:,:)   = -( gc1 * v(ny  ,:,:)  + &
                             gc2 * v(ny-1,:,:)  + &
                             gc3 * v(ny-2,:,:)  + &
                             gc4 * v(ny-3,:,:)  + &
                             gc5 * v(ny-4,:,:)  ) * dyinv

        end if

!.... interior

        g2v(4:ny-3,:,:) = ( gy1 * v(1:ny-6,:,:) + &
                            gy2 * v(2:ny-5,:,:) + &
                            gy3 * v(3:ny-4,:,:) + &
                            gy4 * v(5:ny-2,:,:) + &
                            gy5 * v(6:ny-1,:,:) + &
                            gy6 * v(7:ny  ,:,:) )

!.... Implement Carpenter's boundary stencil

        if (carp .and. (.not. yper) ) then
          g2v(1,:,:)     = ( gg1 * v(1,:,:)     + &
                             gg2 * v(2,:,:)     + &
                             gg3 * v(3,:,:)     + &
                             gg4 * v(4,:,:)     + &
                             gg5 * v(5,:,:)     + &
                             gg6 * v(6,:,:)  ) * dyinv

          g2v(2,:,:)     = ( gh1 * v(1,:,:)     + &
                             gh2 * v(2,:,:)     + &
                             gh3 * v(3,:,:)     + &
                             gh4 * v(4,:,:)     + &
                             gh5 * v(5,:,:)     + &
                             gh6 * v(6,:,:)  ) * dyinv

          g2v(3,:,:)     = ( gi1 * v(1,:,:)     + &
                             gi2 * v(2,:,:)     + &
                             gi3 * v(3,:,:)     + &
                             gi4 * v(4,:,:)     + &
                             gi5 * v(5,:,:)     + &
                             gi6 * v(6,:,:)  ) * dyinv

          g2v(4,:,:)     = ( gj1 * v(1,:,:)     + &
                             gj2 * v(2,:,:)     + &
                             gj3 * v(3,:,:)     + &
                             gj4 * v(4,:,:)     + &
                             gj5 * v(5,:,:)     + &
                             gj6 * v(6,:,:)  ) * dyinv

          g2v(ny-3,:,:) = -( gj1 * v(ny,:,:)    + &
                             gj2 * v(ny-1,:,:)  + &
                             gj3 * v(ny-2,:,:)  + &
                             gj4 * v(ny-3,:,:)  + &
                             gj5 * v(ny-4,:,:)  + &
                             gj6 * v(ny-5,:,:)  ) * dyinv

          g2v(ny-2,:,:) = -( gi1 * v(ny,:,:)    + &
                             gi2 * v(ny-1,:,:)  + &
                             gi3 * v(ny-2,:,:)  + &
                             gi4 * v(ny-3,:,:)  + &
                             gi5 * v(ny-4,:,:)  + &
                             gi6 * v(ny-5,:,:)  ) * dyinv

          g2v(ny-1,:,:) = -( gh1 * v(ny,:,:)    + &
                             gh2 * v(ny-1,:,:)  + &
                             gh3 * v(ny-2,:,:)  + &
                             gh4 * v(ny-3,:,:)  + &
                             gh5 * v(ny-4,:,:)  + &
                             gh6 * v(ny-5,:,:)  ) * dyinv

          g2v(ny,:,:)   = -( gg1 * v(ny,:,:)    + &
                             gg2 * v(ny-1,:,:)  + &
                             gg3 * v(ny-2,:,:)  + &
                             gg4 * v(ny-3,:,:)  + &
                             gg5 * v(ny-4,:,:)  + &
                             gg6 * v(ny-5,:,:)  ) * dyinv
        end if

!.... implement a filter of roundoff noise

!       do idof = 1, ndof
!         do i = 1, nx
!           do j = 1, ny
!             if ( abs(g1v(j,i,idof)) .lt. eps ) g1v(j,i,idof) = zero
!             if ( abs(g2v(j,i,idof)) .lt. eps ) g2v(j,i,idof) = zero
!           end do
!         end do
!       end do

        return
        end


subroutine SolveSystem(n,Matrix,RHS,Solution)
   use typre
   implicit none
   integer(ip) :: n
   real(rp) :: Matrix(n,n), RHS(n), Solution(n)

   integer(ip) :: info
   !Solution is auxiliary for dgesv
   !The solution comes out in RHS
   call DGESV( n, 1_ip, Matrix, n, Solution, RHS, n, INFO )
   Solution = RHS;
end subroutine


!       VERSION 1.0     2/5/99
!**********************************************************************
!                    =========================
!                      subroutine CD2KM
!                    =========================

!                  2
!       Calculate D   (alpha,beta,gamma) as in "Angular Momentum"
!                  k,m
!       by Brink and Satchler, p.24, 2nd ed., Clarendon Press,
!       Oxford (1979).

!                                     2
!       note : d2km(1,i+3,j+3)=real{ D   (alpha,beta,gamma) }
!                                     i,j

!                                     2
!              d2km(2,i+3,j+3)=imag{ D   (alpha,beta,gamma) }
!                                     i,j

!       written by DEB using original routines of DJS and GM

!       Includes:
!               rndoff.inc
!               pidef.inc

!       Uses:

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

    subroutine cd2km(d2km,alpha,beta,gamma)

    include 'rndoff.inc'

    double precision :: alpha,beta,gamma,d2km
    dimension d2km(2,5,5)

    double precision :: dsq32,dsq38,d,cb,sb,cb2,sb2,cd,sd
    integer :: i,j

!######################################################################

    dsq32=dsqrt(3.0D0/2.0D0)
    dsq38=dsqrt(3.0D0/8.0D0)

    call setcs(beta,cb,sb )
    cb2=cb*cb
    sb2=sb*sb

!----------------------------------------------------------------------
!     Set real parts of D2KM elements first
!----------------------------------------------------------------------
    d2km(1,5,5)=0.25D0*(1.0D0+cb)*(1.0D0+cb)
    d2km(1,1,1)=d2km(1,5,5)

    d2km(1,5,4)=-0.5D0*sb*(1.0D0+cb)
    d2km(1,4,5)=-d2km(1,5,4)
    d2km(1,1,2)=-d2km(1,5,4)
    d2km(1,2,1)=d2km(1,5,4)

    d2km(1,5,3)=dsq38*sb2
    d2km(1,3,5)=d2km(1,5,3)
    d2km(1,1,3)=d2km(1,5,3)
    d2km(1,3,1)=d2km(1,5,3)

    d2km(1,5,2)=0.5D0*sb*(cb-1.0D0)
    d2km(1,4,1)=d2km(1,5,2)
    d2km(1,1,4)=-d2km(1,5,2)
    d2km(1,2,5)=-d2km(1,5,2)

    d2km(1,5,1)=(0.5d0*(1.0D0-cb))**2
    d2km(1,1,5)=d2km(1,5,1)

    d2km(1,4,4)=0.5D0*(2.0D0*cb-1.0D0)*(cb+1.0D0)
    d2km(1,2,2)=d2km(1,4,4)

    d2km(1,4,2)=0.5d0*(2.0D0*cb+1.0D0)*(1.0D0-cb)
    d2km(1,2,4)=d2km(1,4,2)

    d2km(1,4,3)=-dsq32*sb*cb
    d2km(1,3,2)=d2km(1,4,3)
    d2km(1,3,4)=-d2km(1,4,3)
    d2km(1,2,3)=-d2km(1,4,3)

    d2km(1,3,3)=0.5D0*(3.0D0*cb2-1.0D0)

!----------------------------------------------------------------------
!    Set imaginary part of D2KM elements
!----------------------------------------------------------------------
    if (dabs(alpha) > rndoff .OR. dabs(gamma) > rndoff) then
        do 20 i=1,5
            do 19 j=1,5
                d=(i-3)*alpha+(j-3)*gamma
                call setcs(d,cd,sd)
                d2km(2,i,j)=-d2km(1,i,j)*sd
                d2km(1,i,j)=d2km(1,i,j)*cd
            19 END DO
        20 END DO
    else
        do 30 i=1,5
            do 29 j=1,5
                d2km(2,i,j)=0.0D0
            29 END DO
        30 END DO
    end if

    return
    end subroutine cd2km

!----------------------------------------------------------------------
!                    =========================
!                       subroutine SETCS
!                    =========================
!   Sets sine and cosine of an angle (given in degrees) after checking
!   special cases
!----------------------------------------------------------------------
    subroutine setcs( ang, ca, sa )
    double precision :: ang,c,ca,sa

!    include 'pidef.inc'
    double precision :: pi,radian
    parameter (pi=3.1415926535897932384D0,radian=pi/180.0D0)
    include 'rndoff.inc'

! Change suggested by Liang made to nino's version 4/29/97:

    if (dabs(ang) < rndoff) then
        sa=0.0D0
        ca=1.0D0
    else if (dabs(180.0D0-ang) < rndoff) then
        sa=0.0D0
        ca=-1.0D0
    else if (dabs(90.0D0-ang) < rndoff) then
        sa=1.0D0
        ca=0.0D0
    else
        c=ang*pi/180.0D0
        sa=dsin(c)
        ca=dcos(c)
    end if
    return
    end subroutine setcs


      DOUBLE PRECISION FUNCTION ANOMLY2(IND,ANGLE,ECC,IERPNT,IERR)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  THIS ROUTINE COMPUTES ECCENTRIC ANOMALY GIVEN TRUE ANOMALY AND
C  VIS-VERSA.
C
C  VAR    DIM TYPE  I/O  DESCRIPTION
C  ---    --- ----  ---  -----------
C
C  IND     1  I*4    I   INDICATOR ON ANGLE TYPE.
C
C                        =ZERO OR POSITIVE. ECCENTRIC ANOMALY INPUT,
C                         TRUE ANOMALY OUTPUT.
C                        =NEGATIVE. TRUE ANOMALY INPUT, ECCENTRIC
C                         OUTPUT.
C
C  ANGLE   1  R*8    I   ANGLE TO BE CONVERTED. ECCENTRIC OR TRUE
C                        ANOMALY, DEPENDING ON VALUE OF IND INPUT.
C                        RADIANS.
C
C  ECC     1  R*8    I   ECCENTRICITY. MUST BE ZERO OR POSITIVE AND
C                        LESS THAN 1.D0
C
C  IERPNT  1  I*4    I   FORTRAN UNIT FOR ERROR MESSAGE. USED WHEN AN
C                        INVALID ECC HAS BEEN INPUT.
C                        =0 MEANS NO ERROR MESSAGE IS TO BE GIVEN.
C
C  IERR    1  I*4    O   ERROR RETURN FLAG.
C                        =0, NO ERROR.  =1, ERROR.
C
C***********************************************************************
C
C  BY C PETRUZZO/GSFC/742      10/85.
C        MODIFIED......
C
C***********************************************************************
C
      REAL*8 TWOPI/  6.283185307179586D0    /
C
C
C  EQUATIONS ARE FROM THE ORBITAL FLIGHT HANDBOOK(MARTIN CO., 1963.)
C  VOL I, PAGE III-21, EQNS 2-6,2-7 AND PAGE III-23, EQNS 2-57,2-59.
C
      IERR = 0
C
C ERROR CHECK.
C
      IF(ECC.LT.0.D0 .OR. ECC.GE.1.D0) THEN
        IERR = 1
        ANOMLY2 = 0.D0
        IF(IERPNT.NE.0) WRITE(IERPNT,1500) IND,ANGLE,ECC
 1500   FORMAT('0ANOMLY2. BIG ERROR. ECCENTRICITY NOT FOR AN ELLIPSE.'/,
     *         '    IND,ANGLE,ECC=',I3,2G20.10)
        GO TO 9000
        END IF
C
C INITIALIZE ANG1 AND DIF2PI. DIF2PI IS USED IN CASE ANG1 IS OUTSIDE
C OF THE 0 TO TWOPI RANGE.
C
      TEMP = DABS(ANGLE)
      ANG1 = DMOD(TEMP,TWOPI)
      DIF2PI = TEMP - ANG1
C
C COMPUTE THE OUTPUT ANGLE.
C
      IF(IND.GE.0) THEN
C
C  >> GET TRUE ANOMALY FROM ECCENTRIC ANOMALY <<
        ECANOM = ANG1
        COSE = DCOS(ECANOM)
        SINE = DSIN(ECANOM)
        X = COSE-ECC                          ! FROM EQN 2-57
        Y = SINE*DSQRT(1.D0-ECC*ECC)          ! FROM EQN 2-59
        TRUANM = DATAN2(Y,X)
        ANG2 = EQVANG( TRUANM )
C
      ELSE
C  >> GET ECCENTRIC ANOMALY FROM TRUE ANOMALY <<
        TRUANM = ANG1
        COSTRU = DCOS(TRUANM)
        SINTRU = DSIN(TRUANM)
        X = ECC+COSTRU                        ! FROM EQN 2-7
        Y = SINTRU*DSQRT(1.D0-ECC*ECC)        ! FROM EQN 2-6
        ECANOM = DATAN2(Y,X)
        ANG2 = EQVANG( ECANOM )
        END IF
C
      ANG2 = ANG2 + DIF2PI
      IF(ANGLE.LT.0.D0) ANG2 = -ANG2
      ANOMLY2 = ANG2
C
 9000 RETURN
      END


! -*- f90 -*-
! file lbfgs.f90
! Approximate Hessian inversion
! version 0.1
SUBROUTINE lbfgs(n, H_0, k, s, y, d)

!*****************************************************************
!
!   subroutine lbfgs
!
!   Approximately apply the inverse Hessian to d.
!   n: dim of H_0 (nxn) and d (n)
!   d: Vector to mupltiply by. On exit, the result of the multiplication
!
!*****************************************************************
    IMPLICIT NONE

    INTEGER ::  k, n
    REAL (KIND=8) ::  H_0(n,n), s(n,k), y(n,k), d(n)

    INTEGER :: i,j
    REAL (KIND=8) ::  a(k), b(k), rho(k)

!    print *, n,k !    print *,'s',s !    print *,'y',y

    do i=1,k-1
        rho(i) = 1.0/DOT_PRODUCT(y(:,i), s(:,i))
    end do

    do i=k-1, 1,-1
        a(i) =  rho(i)*(DOT_PRODUCT(s(:,i), d))
        d = d - a(i)*y(:,i) ! might need to modify here?
    end do

    d = MATMUL(H_0, d)

    do i=1,k-1
       b(i) = rho(i)*(DOT_PRODUCT(y(:,i), d))
       !print *,i, b(i), rho(i)
       d = d + (a(i)-b(i))*s(:,i) ! might also need a tweak here
       !print *,'d',d
    end do

END SUBROUTINE lbfgs

SUBROUTINE update_storage(n, k, istep, s, y, d_x, d_jac, info)

    IMPLICIT NONE

    INTEGER :: n,k,istep

    REAL(KIND=8) :: s(n,k), y(n,k)
    REAL(KIND=8) :: d_x(n), d_jac(n)

    INTEGER :: i, info

    info = 1
    do i=1,n
        if (ABS(d_x(i)) .LE. 1.0E-015) then
            info = 0
        end if
    end do

    !print *,'s',s(1,:)
    !print *,'y',y(1,:)
    if (info .EQ. 1) then
        if (istep .LE. k) then
            !no shuffling needed
            s(:,istep) = d_x
            y(:,istep) = d_jac
        else
            do i=2,k
                s(:,i-1) = s(:,i)
                y(:,i-1) = y(:,i)
            end do
        s(:,k) = d_x
        y(:,k) = d_jac
        end if
    end if

    !print *,'s',s(1,:)
    !print *,'y',y(1,:)
!    print *,' '

END SUBROUTINE update_storage


module compute_n_steady_module

  use ml_layout_module
  use multifab_physbc_module
  use define_bc_module
  use bc_module
  use bndry_reg_module
  use ml_solve_module
  use probin_reactdiff_module, only: nspecies, mg_verbose, cg_verbose, &
       implicit_diffusion_rel_eps, implicit_diffusion_abs_eps, D_Fick

  implicit none

  private

  public :: compute_n_steady

contains

  subroutine compute_n_steady(mla,n_steady,dx,dt,the_bc_tower)

    ! compute div D_k grad n_steady_k = 0 with inhomogeneous boundary conditions

    type(ml_layout), intent(in   ) :: mla
    type(multifab) , intent(inout) :: n_steady(:)
    real(kind=dp_t), intent(in   ) :: dx(:,:),dt
    type(bc_tower) , intent(in   ) :: the_bc_tower

    ! for multigrid solver; (alpha - div beta grad) phi = rhs
    type(multifab) :: alpha(mla%nlevel)
    type(multifab) :: rhs(mla%nlevel)
    type(multifab) :: phi(mla%nlevel)
    type(multifab) :: beta(mla%nlevel,mla%dim)

    ! for diffusion multigrid - not used but needs to be passed in
    type(bndry_reg) :: fine_flx(mla%nlevel)

    integer :: i,dm,n,nlevs,spec

    type(bl_prof_timer),save :: bpt

    nlevs = mla%nlevel
    dm = mla%dim

    ! if we are periodic in all directions, set n_steady=0 and return
    if (all(mla%pmask(1:dm))) then
       do n=1,nlevs
          call multifab_setval(n_steady(n),0.d0,all=.true.)
       end do
       return
    end if

    call build(bpt,"compute_n_steady")

    ! for multigrid solver; (alpha - div beta grad) phi = rhs
    do n=1,nlevs
       call multifab_build(alpha(n),mla%la(n),1,0)
       call multifab_build(rhs(n)  ,mla%la(n),1,0)
       call multifab_build(phi(n)  ,mla%la(n),1,1)
       do i=1,dm
          call multifab_build_edge(beta(n,i),mla%la(n),1,0,i)
       end do
    end do

    ! stores beta*grad phi/dx_fine on coarse-fine interfaces
    ! this gets computed inside of ml_cc_solve
    ! we pass it back out because some algorithms (like projection methods)
    ! use this information
    do n = 1,nlevs
       call bndry_reg_build(fine_flx(n),mla%la(n),ml_layout_get_pd(mla,n))
    end do

    do n=1,nlevs
       call multifab_setval(alpha(n),0.d0,all=.true.)
       call multifab_setval(rhs(n),0.d0,all=.true.)
    end do

    do spec=1,nspecies

       ! beta = D_k
       do n=1,nlevs
          do i=1,dm
             call multifab_setval(beta(n,i),D_Fick(spec),all=.true.)
          end do
       end do

       ! initial guess for phi
       ! zero on the interior, ghost cells filled with Dirichlet value
       do n=1,nlevs
          call multifab_setval(phi(n),0.d0,all=.true.)
          call multifab_physbc(phi(n),1,scal_bc_comp+spec-1,1, &
                               the_bc_tower%bc_tower_array(n),dx_in=dx(n,:))
       end do

       ! solve the Poisson equation
       call ml_cc_solve(mla,rhs,phi,fine_flx,alpha,beta,dx, &
                        the_bc_tower,scal_bc_comp+spec-1, &
                        stencil_order=1, &
                        verbose=mg_verbose, &
                        cg_verbose=cg_verbose, &
                        eps=implicit_diffusion_rel_eps, &
                        abs_eps=implicit_diffusion_abs_eps)

       ! copy solution into n_new
       do n=1,nlevs
          call multifab_copy_c(n_steady(n),spec,phi(n),1,1,0)
       end do

    end do

    do n=1,nlevs
       call multifab_destroy(alpha(n))
       call multifab_destroy(rhs(n))
       call multifab_destroy(phi(n))
       do i=1,dm
          call multifab_destroy(beta(n,i))
       end do
    end do

    do n = 1,nlevs
       call bndry_reg_destroy(fine_flx(n))
    end do

    call destroy(bpt)

  end subroutine compute_n_steady

end module compute_n_steady_module


c=======================================================================
c
c     subroutine  NLSB
c
c     Non-Linear Least-Square Solver (with lower/upper bounds)
c
c     min || y - f(x) ||**2   s.t. binf <= x <= bsup
c      x
c
c     where f(.) is a differentiable function of x
c
c------------------------------------------------------------------------
      SUBROUTINE nlsb ( simext, mxopt, nfct, xini, obs, binf, bsup,
     &                  spadim, grid, epsbfg,
     &                  liudat, iudata, ldudat, dudata,
     &                  iwork, dwork, xopt, fxopt, gxopt, info )
c-----------------------------------------------------------------------
c     INPUT :
c            SIMEXT : entry point of an external subroutine
c                     provided by the user
c            mxopt  : number of parameters to find               integer
c            nfct   : number of functions (observations)         integer
c            xini   : initial solution  vector(mxopt)             double
c            obs    : observations  vector(nfct)                  double
c            binf   : inferior bounds on parameters vector(mxopt) double
c            bsup   : superior bounds on parameters vector(mxopt) double
c            spadim : space dimension                            integer
c            grid   : grid     vector(nfct*spadim)                double
c            epsbfg : BFGS precision stop test                    double
c            liudat : size of integer user data for SIMEXT       integer
c            iudata : integer user data for SIMEXT               integer
c                     vector(liudat)
c            ldudat : size of double prec. user data for SIMEXT  integer
c            dudata : double precision user data for SIMEXT       double
c                     vector(ldudat)
c
c     WORKSPACE
c            iwork  : workspace                                  integer
c                     vector( 2*mxopt + 6 + liudat )
c            dwork  : double precision  workspace                 double
c                     vector( mxopt*(mxopt+13)/2
c                           + nfct*(mxopt+3+spadim) + ldudat )
c
c     OUTPUT
c            xopt   : optimal point (mxopt)                       double
c            fxopt  : function value at optimal point             double
c            gxopt  : gradient value at optimal point (mxopt)     double
c            info   : = 0 successful exit                        integer
c
c     CALL
c         YV       : copy a vector in a vector
c         YVI      : copy a vector of integers in a vector of integers
c         BFGSBOXS : quasi-Newton optimizer with BFGS method
c                    (short call version)
c         SIMNLS   : subroutine used by BFGS to compute the value of the
c                   function and its gradient
c
c-----------------------------------------------------------------------
c
c     SIMEXT SIGNATURE
c
c     INPUT
c            nfct   : number of functions                        integer
c            mxopt  : size of the vector solution                integer
c            xopt   : solution  vector(mxopt)                     double
c            spadim : space dimension                            integer
c            grid   : grid     vector(nfct*spadim)                double
c            liudat : size of integers data provided by the user integer
c            iusdat : integers user data provided by the user
c                     vector(liudat)                             integer
c            ldudat : size of doubles data provided by the user  integer
c            dusdat : doubles user data provided by the user
c                     vector(ldudat)                              double
c
c     OUTPUT
c            funct  : functions   vector(nfct)                    double
c            jacob  : jacobian    matrix(nfct*mx)                 double
c            info   : = 0 successful exit                        integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     external functions
      EXTERNAL simext, simnls, YV, YVI, bfgsboxs
c
c     arguments i/o
      INTEGER mxopt, nfct, spadim, liudat, ldudat, info
      INTEGER iudata(*)
      DOUBLE PRECISION epsbfg
      DOUBLE PRECISION binf(*), bsup(*), obs(*), xini(*), grid(*),
     &                 dudata(*), xopt(*), fxopt, gxopt(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER totitr, totsim, piwbf, pnfct, pspad, pliu, pldu, pinfo,
     &        piwu, pgrad, pdwbf, pwsnls, pwsext, pobs, pgrid, pdwu
c
c-----------------------------------------------------------------------
c
c     initializations
      info = 0
      fxopt = 0
      CALL YV ( mxopt, xini, gxopt )
c
c     pointers for integer work space  : iwork
c     ----------------------------------------
      piwbf  = 1
c     piwbf  : pointer for BFGSBOXS who needs (2*mxopt + 1)
c              so (2*mxopt + 1) more
      pnfct  = piwbf + (2*mxopt + 1)
c     pnfct  : pointer for the number of functions, ( communication
c              with SIMEXT, user simulator )
      pspad  = pnfct + 1
c     pspad  : pointer for the space dimension ( communication
c              with SIMEXT, user simulator )
      pliu   = pspad + 1
c     pliu   : pointer for size of integers data provided by the user,
c              ( communication with SIMEXT, user simulator )
      pldu   = pliu + 1
c     pldu   : pointer for size of doubles data provided by the user,
c              ( communication with SIMEXT, user simulator )
      pinfo  = pldu + 1
c     pinfo  : pointer for info (errors of SIMNLS)
      piwu   = pinfo + 1
c     piwu   : pointer for user SIMEXT workspace, so (liudat) more
c
c     Total size of iwork array = (2*mxopt + 6) + liudat
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pgrad = 1
c     pgrad : pointer for gradient at solution, so mxopt more
c
      pdwbf = pgrad + mxopt
c     pdwbf : pointer for BFGSBOXS who needs ( mxopt*(mxopt+11)/2 )
c             so ( mxopt*(mxopt+11)/2 ) more
      pwsnls = pdwbf +  mxopt*(mxopt+11)/2
c     pwsnls: pointer for workspace of SIMNLS, so (nfct*(mxopt+2)) more
      pwsext = pwsnls + nfct*(mxopt+2)
c     pwsext: pointer for workspace ( communication with SIMNLS
c             and SIMEXT, BFGSBOXS simulator ),
c             so ( nfct*(spadim+1) + ldudat ) more
      pobs = pwsext
c     pobs  : pointer for the vector of observations ( communication
c             with SIMNLS, BFGSBOXS simulator ), so nfct  more
c
      pgrid = pobs +  nfct
c     pgrid : pointer for grid matrix ( communication with SIMEXT,
c             user simulator ), so (nfct*spadim) more
      pdwu = pgrid + (nfct*spadim)
c     pdwu   : pointer for user SIMEXT workspace, so (ldudat) more
c
c     Total size of dwork array = mxopt + mxopt*(mxopt+11)/2
c                                 + ( nfct*(mxopt+2) )
c                                 + ( nfct*(spadim+1) ) + ldudat
c          = mxopt*(mxopt+13)/2 + nfct*(mxopt+3+spadim) + ldudat
c
c-----------------------------------------------------------------------
c
c     communication with SIMNLS (BFGSBOXS simulator)
c                    and SIMEXT (user simulator)
      iwork(pnfct) = nfct
      iwork(pspad) = spadim
      iwork(pliu)  = liudat
      iwork(pldu)  = ldudat
      iwork(pinfo) = 0
      CALL YV ( nfct, obs, dwork(pobs) )
      CALL YV ( nfct*spadim, grid, dwork(pgrid) )
      CALL YV ( ldudat, dudata, dwork(pdwu) )
      CALL YVI ( liudat, iudata, iwork(piwu) )
c
c     optimization BFGS-box
      CALL bfgsboxs ( simnls, simext, mxopt, xini, epsbfg, binf, bsup,
     &                iwork(piwbf), dwork(pdwbf),
     &                xopt, fxopt, gxopt, totitr, totsim, info)
c
c     gestion of SIMNLS errors
      IF (iwork(pinfo).ne.0) THEN
         info = iwork(pinfo)
         RETURN
      ENDIF
c
      RETURN
      END


module vd2d_mms_mod_3
    implicit none
    real, parameter :: pi = 3.1415926535897932
    real, private :: k,w,rho0,rho1,D,mu, uf

    !functions
    PUBLIC :: vd2d_mms_init_3
    PUBLIC :: vd2d_mms_rho_of_z
    PUBLIC :: vd2d_mms_z
    PUBLIC :: vd2d_mms_rho
    PUBLIC :: vd2d_mms_u
    PUBLIC :: vd2d_mms_v
    PUBLIC :: vd2d_mms_p
    PUBLIC :: vd2d_mms_z_src
    PUBLIC :: vd2d_mms_u_src
    PUBLIC :: vd2d_mms_v_src
!————————————————————————————————————————————————————————————————————————————————————————
contains
!————————————————————————————————————————————————————————————————————————————————————————
    subroutine vd2d_mms_init_3 (wave_num,freq,wave_vel,rho_0,rho_1,visc,diff)
        implicit none
        real, intent (in) :: wave_num, freq, wave_vel, rho_0, rho_1, visc, diff
        k = wave_num
        w = freq
        rho0 = rho_0
        rho1 = rho_1
        mu = visc
        D = diff
        uf = wave_vel
    end subroutine vd2d_mms_init_3
    !————————————————————————————————————————————————————————————————————————————————————————
    function vd2d_mms_rho_of_z (z)
        implicit none
        real, intent (in) :: z
        real  :: vd2d_mms_rho_of_z
        vd2d_mms_rho_of_z = 1.0/(z/rho1+(1.0-z)/rho0)
    end function vd2d_mms_rho_of_z
    !————————————————————————————————————————————————————————————————————————————————————————
    function vd2d_mms_z (x,y,t)
        implicit none
        real, intent (in) :: x,y,t
        real  :: vd2d_mms_z
        real  :: xt,yt
        xt = x - uf*t
        yt = y - uf*t

        vd2d_mms_z = &
            (1.0 + sin (k * pi * xt) * sin (k * pi * yt) * cos (w * pi * t))/ &
            (1.0 + rho0/rho1+(1.0-rho0/rho1)&
            * sin (k * pi * xt) * sin (k * pi * yt) * cos (w * pi * t))
    end function vd2d_mms_z
    !————————————————————————————————————————————————————————————————————————————————————————
    function vd2d_mms_rho (x,y,t)
        implicit none
        real, intent (in) :: x,y,t
        real  :: vd2d_mms_rho
        vd2d_mms_rho = vd2d_mms_rho_of_z (vd2d_mms_z (x,y,t))
    end function vd2d_mms_rho
    !————————————————————————————————————————————————————————————————————————————————————————
    function vd2d_mms_u (x,y,t)
        implicit none
        real, intent (in) :: x,y,t
        real  :: vd2d_mms_u
        real  :: xt,yt
        xt = x - uf*t
        yt = y - uf*t

        vd2d_mms_u=-w/k/4.0 * cos (k * pi * xt) * sin (k * pi * yt) * sin (w * pi * t)&
            * (rho1-rho0)/vd2d_mms_rho (x,y,t)
    end function vd2d_mms_u
    !————————————————————————————————————————————————————————————————————————————————————————
    function vd2d_mms_v (x,y,t)
        implicit none
        real, intent (in) :: x,y,t
        real  :: vd2d_mms_v
        vd2d_mms_v = vd2d_mms_u (y,x,t)
    !! NOTE: v obtained from u by transposing x <–> y
    end function vd2d_mms_v
    !————————————————————————————————————————————————————————————————————————————————————————
    function vd2d_mms_p (x,y,t)
        implicit none
        real, intent (in) :: x,y,t
        real  :: vd2d_mms_p
        vd2d_mms_p = &
            vd2d_mms_rho (x,y,t) * vd2d_mms_u (x,y,t) * vd2d_mms_v (x,y,t)/2.0
    !! NOTE: pressure can vary by a constant and still satisfy the mms
    end function vd2d_mms_p
    !————————————————————————————————————————————————————————————————————————————————————————
    function vd2d_mms_z_src (x,y,t)
        implicit none
        real, intent (in) :: x,y,t
        real  :: vd2d_mms_z_src
        real  :: s0,s1,s2,s3,s4,s5,s6,s7,s8,&
            s9,s10,s11,s12,s13,s14,s15,s16
        s0 = cos (w * pi * t)
        s1 = sin (w * pi * t)
        s2 = cos (k * pi * x)
        s3 = sin (k * pi * x)
        s4 = cos (k * pi * y)
        s5 = sin (k * pi * y)
        s6 = rho1-rho0
        s7 = 1.0 + s3 * s5 * s0
        s8 = (0.5 + 0.5 * s3 * s5 * s0) * s6 + rho0! rho
        s9 = rho1 * s3 * s5 * s0 + rho1-s3 * s5 * s0 * rho0 + rho0
        s10 = rho1 * s2 * k * pi * s5 * s0-s2 * k * pi * s5 * s0 * rho0
        s11 = rho1 * s3 * s4 * k * pi * s0-s3 * s4 * k * pi * s0 * rho0
        s12 = rho0 * s3 * s5 * s1 * w * pi-s3 * s5 * s1 * w * pi * rho1
        s13 = s3 * k ** 2 * pi ** 2 * s5 * s0 * rho0-rho1 * s3 * k ** 2 * pi ** 2 * s5 * s0
        s14 = 1.0/4.0
        s15 = 2.0 * D
        s16 = s15 * pi * pi
        vd2d_mms_z_src=&
            -rho1 * (s8 * s3 * s5 * s1 * w * pi * s9 ** 2 * k + s8 * s7 * s12 * s9 * k + s14 * s2 ** 2 * pi * s5 ** 2 &
            * s0 * s1 * w * s6 * s9 ** 2 * k-s14 * s7 * s5 * s1 * w * s6 * s2 * s10 * s9 + s14 * s3 ** 2 * s4 ** 2 * pi &
            * s0 * s1 * w * s6 * s9 ** 2 * k-s14 * s7 * s3 * s1 * w * s6 * s4 * s11 * s9-s16 * k ** 3 * s3 * s5 * s0 &
            * s9 ** 2-s15 * k ** 2 * s2 * pi * s5 * s0 * s10 * s9 + s15 * k * s7 * s10 ** 2-s15 * k * s7 * s13 * s9 &
            -s15 * k ** 2 * s3 * s4 * pi * s0 * s11 * s9 + s15 * k * s7 * s11 ** 2)/s9 ** 3/k
    end function vd2d_mms_z_src
    !————————————————————————————————————————————————————————————————————————————————————————
    function vd2d_mms_u_src (x,y,t)
        implicit none
        real, intent (in) :: x,y,t
        real  :: vd2d_mms_u_src
        real  :: s0,s1,s2,s3,s4,s5,s6,s7,s8,&
            s9,s10,s11,s12,s13,s14,s15
        s0 = cos (w * pi * t)
        s1 = sin (w * pi * t)
        s2 = cos (k * pi * x)
        s3 = sin (k * pi * x)
        s4 = cos (k * pi * y)
        s5 = sin (k * pi * y)
        s6 = rho1-rho0
        s7=(0.5 + 0.5 * s3 * s5 * s0) * s6 + rho0! rho
        s8 = 1.0/64.0
        s9 = s8 * 2.0
        s10 = s9 * 2.0
        s11 = s10 * 3.0
        s12 = s10 * 4.0
        s13 = pi * pi/6.0
        s14 = s13 * 2.0
        s15 = s14 * 2.0
        vd2d_mms_u_src=&
            w * s6 * (-s12 * s5 * s0 * w * pi * s2 * s7 ** 3-s11 * s5 ** 2 * s1 ** 2 * w * s6 * s2 * s3 * pi * s7 ** 2 &
            -s9 * s5 ** 3 * s1 ** 2 * w * s6 ** 2 * s2 ** 3 * pi * s0 * s7 + s10 * s4 ** 2 * pi * s1 ** 2 * w * s6 * s2 * s3 &
            * s7 ** 2-s9 * s5 * s1 ** 2 * w * s6 ** 2 * s2 * s3 ** 2 * s4 ** 2 * pi * s0 * s7-s15 * mu * s1 * s2 * k ** 2 &
            * s5 * s7 ** 2 + s15 * mu * s1 * s2 * k ** 2 * s5 ** 2 * s6 * s3 * s0 * s7 + s13 * mu * s1 * s2 ** 3 * k ** 2 &
            * s5 ** 3 * s6 ** 2 * s0 ** 2-s14 * mu * s1 * s2 * k ** 2 * s3 * s6 * s4 ** 2 * s0 * s7 + s13 * mu * s1 * s2 &
            * k ** 2 * s3 ** 2 * s6 ** 2 * s4 ** 2 * s0 ** 2 * s5-s9 * s5 * s1 ** 2 * w * s6 * s3 ** 2 * pi * s4 * s7 ** 2 &
            + s9 * s5 * s1 ** 2 * w * s6 * s2 ** 2 * pi * s4 * s7 ** 2-s8 * s5 ** 2 * s1 ** 2 * w * s6 ** 2 * s2 ** 2 * s3 &
            * s4 * pi * s0 * s7)/k/s7 ** 3
    end function vd2d_mms_u_src
    !————————————————————————————————————————————————————————————————————————————————————————
    function vd2d_mms_v_src (x,y,t)
        implicit none
        real, intent (in) :: x,y,t
        real  :: vd2d_mms_v_src
        vd2d_mms_v_src = vd2d_mms_u_src (y,x,t)
    !! NOTE: v obtained from u by transposing x <–> y
    end function vd2d_mms_v_src
end module vd2d_mms_mod_3


	subroutine swr_depstor

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine computes maximum surface depressional storage depth based on
!!    random and oriented roughness and slope steepness

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    iop(:,:,:)  |julian date   |date of tillage operation
!!    mgt_op      |none          |operation code number
!!    ranrns_hru(:)|mm           |random roughness for a given HRU
!!	sol_ori(:)	|mm			   |oriented roughness (ridges) at time of a given tillage operation
!!    usle_ei     |100(ft-tn in)/(acre-hr)|USLE rainfall erosion index
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!	stmaxd(:)	|mm			   |maximum surface depressional storage for day in a given HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!	cumei(:)	|Mj*mm/ha*hr   |cumulative USLE rainfall erosion index since last
!!							   |tillage operation
!!	cumrt(:)	|mm H2O		   |cumulative rainfall since last tillage operation
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic:exp
!!    SWAT:eiusle

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

      use hru_module, only : hru, cumeira, cumei, cumrt, cumrai, ranrns_hru, stmaxd, itill, ihru,  &
         itill, precip_eff, usle_ei
      use soil_module
      use organic_mineral_mass_module

      implicit none

      integer ::j               !none          |HRU number
	  real:: df                 !none		   |oriented and random roughness decay factor - based
                                !              |on cumulative EI and cumulative precip_eff
      real:: hru_slpp           !%	           |average percent slope steepness
      real:: sol_orgm           !%      	   |percent organic matter content in soil material
      real:: sol_orr            !cm			   |oriented roughness (ridges) after a rain event
      real:: sol_rrr            !cm			   |random roughness after a rain event
      real:: ei                 !Mj*mm/ha*hr   |USLE rainfall erosion index
      real :: xx                !              |

      j = ihru

!! Calculate current cummulative erosivity and rainfall
	ei = usle_ei*18.7633
	if (itill(j) ==1)then
	  cumeira(j) = cumeira(j) + ei
	  cumei(j) = cumeira(j) - ei
	  cumrai(j) = cumrai(j) + precip_eff
	  cumrt(j) = cumrai(j) - precip_eff
      end if
!! Calculate the decay factor df based on %clay and %organic matter or %organic carbon
	sol_orgm = soil1(j)%tot(1)%c / 0.58
	xx = (0.943 - 0.07 * soil(j)%phys(1)%clay + 0.0011 *                 &
         soil(j)%phys(1)%clay**2 - 0.67 * sol_orgm + 0.12 * sol_orgm**2)
      if (xx > 1.) then
        df = 1.
      else
        df = exp (xx)
      end if

!! Determine the current random and oriented roughness using cumei and cumrt and initial
!! random and oriented roughness values

	sol_rrr = 0.1 * ranrns_hru(j)                                      &
       	* exp(df*(-0.0009*cumei(j)-0.0007 * cumrt(j)))

!	sol_orr = 0.1*sol_ori(j)*
!     &	exp(df*(-0.025*(cumei(j)**0.31)-0.0085*(cumrt(j)**0.567)))

!! Compute the current maximum depressional storage using percent slope steepness
!! and current random and oriented roughness values determined above
	hru_slpp = hru(j)%topo%slope*100
!	if(irk=0) then !irk=0 for random rough, and irk=1, for oriented roughness
	stmaxd(j)= 0.112*sol_rrr+0.031*sol_rrr**2-0.012*sol_rrr*hru_slpp
!	else
!	stmaxd(j)= 0.112*sol_orr+0.031*sol_orr**2-0.012*sol_orr*hru_slpp
!	endif

   	return
	end subroutine swr_depstor


SUBROUTINE stability(kv,gv,kdiag,tol,limit,iters,evec,eval)
!
! This subroutine computes the smallest eigenvalue in a beam
! stability analysis.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER,INTENT(IN)::limit,kdiag(:)
 INTEGER,INTENT(OUT)::iters
 INTEGER::neq
 REAL(iwp),INTENT(IN OUT)::kv(:),gv(:),tol,eval
 REAL(iwp),INTENT(OUT)::evec(:)
 REAL(iwp)::big,zero=0.0_iwp,one=1.0_iwp
 LOGICAL::converged
 REAL(iwp),ALLOCATABLE::x0(:),x1(:)
 neq=UBOUND(kdiag,1)
 ALLOCATE(x0(0:neq),x1(0:neq))
 CALL sparin(kv,kdiag)
 iters=0
 x0=zero
 x0(1)=1.0_iwp
 DO
   iters=iters+1
   CALL linmul_sky(gv,x0,x1,kdiag)
   CALL spabac(kv,x1,kdiag)
   big=MAXVAL(x1(1:))
   IF(ABS(MINVAL(x1(1:)))>big)big=MINVAL(x1(1:))
   x1=x1/big
   converged=(MAXVAL(ABS(x1(1:)-x0(1:)))/MAXVAL(ABS(x1(1:)))<tol)
   x0=x1
   IF(converged.OR.iters==limit)EXIT
 END DO
 x1(1:)=x1(1:)/SQRT(SUM(x1(1:)**2))
 evec=x1
 eval=one/big
RETURN
CONTAINS
SUBROUTINE sparin(kv,kdiag)
!
! This subroutine performs Cholesky factorisation on a symmetric
! skyline global matrix.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN OUT)::kv(:)
 INTEGER,INTENT(IN)::kdiag(:)
 INTEGER::n,i,ki,l,kj,j,ll,m,k
 REAL(iwp)::x
 n=UBOUND(kdiag,1)
 kv(1)=SQRT(kv(1))
 DO i=2,n
   ki=kdiag(i)-i
   l=kdiag(i-1)-ki+1
   DO j=l,i
     x=kv(ki+j)
     kj=kdiag(j)-j
     IF(j/=1)THEN
       ll=kdiag(j-1)-kj+1
       ll=max(l,ll)
       IF(ll/=j)THEN
         m=j-1
         DO k=ll,m
           x=x-kv(ki+k)*kv(kj+k)
         END DO
       END IF
     END IF
     kv(ki+j)=x/kv(kj+j)
   END DO
   kv(ki+i)=SQRT(x)
 END DO
RETURN
END SUBROUTINE sparin
SUBROUTINE spabac(kv,loads,kdiag)
!
! This subroutine performs Cholesky forward and back-substitution
! on a symmetric skyline global matrix.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::kv(:)
 REAL(iwp),INTENT(IN OUT)::loads(0:)
 INTEGER,INTENT(IN)::kdiag(:)
 INTEGER::n,i,ki,l,m,j,it,k
 REAL(iwp)::x
 n=UBOUND(kdiag,1)
 loads(1)=loads(1)/kv(1)
 DO i=2,n
   ki=kdiag(i)-i
   l=kdiag(i-1)-ki+1
   x=loads(i)
   IF(l/=i)THEN
     m=i-1
     DO j=l,m
       x=x-kv(ki+j)*loads(j)
     END DO
   END IF
   loads(i)=x/kv(ki+i)
 END DO
 DO it=2,n
   i=n+2-it
   ki=kdiag(i)-i
   x=loads(i)/kv(ki+i)
   loads(i)=x
   l=kdiag(i-1)-ki+1
   IF(l/=i)THEN
     m=i-1
     DO k=l,m
       loads(k)=loads(k)-x*kv(ki+k)
     END DO
   END IF
 END DO
 loads(1)=loads(1)/kv(1)
RETURN
END SUBROUTINE spabac
SUBROUTINE linmul_sky(kv,disps,loads,kdiag)
!
! This subroutine forms the product of symmetric matrix stored as
! a skyline and a vector.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::kv(:),disps(0:)
 REAL(iwp),INTENT(OUT)::loads(0:)
 INTEGER,INTENT(IN)::kdiag(:)
 INTEGER::n,i,j,low,lup,k
 REAL(iwp)::x,zero=0.0_iwp
 n=UBOUND(disps,1)
 DO i=1,n
   x=zero
   lup=kdiag(i)
   IF(i==1)low=lup
   IF(i/=1)low=kdiag(i-1)+1
   DO j=low,lup
     x=x+kv(j)*disps(i+j-lup)
   END DO
   loads(i)=x
   IF(i==1)CYCLE
   lup=lup-1
   DO j=low,lup
     k=i+j-lup-1
     loads(k)=loads(k)+kv(j)*disps(i)
   END DO
 END DO
RETURN
END SUBROUTINE linmul_sky
END SUBROUTINE stability


!       burgers equation using Lax-Frederichs scheme

!Copyright (c) 2021 G99k

!Permission is hereby granted, free of charge, to any person obtaining a copy
!of this software and associated documentation files (the "Software"), to deal
!in the Software without restriction, including without limitation the rights
!to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
!copies of the Software, and to permit persons to whom the Software is
!furnished to do so, subject to the following conditions:

!The above copyright notice and this permission notice shall be included in all
!copies or substantial portions of the Software.

!THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
!AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
!OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
!SOFTWARE.

      program burgerlf
      implicit none
      integer i, j, nx, nt
      double precision u, u1, xmax, xmin, dx, cfl, umax, t, dt, sig, xi
     *, z, w, y
      dimension u1(10001),u(10001), z(10001), w(10001), y(10001)
      xmax = 5.d0
      xmin = 0.0d0
      dx = 0.1d0
      nx = int((xmax-xmin)/dx)

      cfl = 0.1d0
      umax = 2.d0
      t = 1.d0

      dt = (cfl*dx)/umax
      nt = int(t/dt)

      sig=dt/dx

      write(*,*) nt
      write(*,*) nx

! initialization
      u(1) = 2.0d0
      do i=2,nx+1
         u(i) = 1.d0
      enddo
      z=2.0d0
      w=2.0d0
      y=2.0d0
comm time loop
      do j=1,nt
      do i=2,nx+1

      ! 1st formula
         u1(i)=(0.5)*(u(i+1)+u(i-1))-(dt/(4*dx))*(u(i+1)**2-u(i-1)**2)

! boundary conditions
      u1(1)   =2.0d0
      u1(nx+1)=1.d0

      if(j .eq. int(nt/4)) then
      z(i)=u1(i)
      else if (j .eq. int(nt/2)) then
      w(i)=u1(i)
      else if (j.eq. int(3*nt/4)) then
      y(i)=u1(i)
      endif
      enddo

! update u
      do i=1,nx+1
         u(i)=u1(i)
      enddo

      enddo
comm end time loop

! saving solution

      open(60,file='solution_cfl=0.1')

      xi=0.d0
      do i=1,nx+1
         xi=xi+dx
         write(60,999)xi,u1(i)
         write(61,999)xi,z(i)
         write(62,999)xi,w(i)
         write(63,999)xi,y(i)
         write(*, 999)xi,u1(i)
      end do

999   format(2f12.6)
      close(60)

      stop '### Everything is OK ###'
      end program burgerlf


      subroutine clawpack46_qinit(maxmx,maxmy,meqn,mbc,mx,my,
     &      xlower,ylower,dx,dy,q,maux,aux)
c     =====================================================
c
c     # Set initial conditions for q.
c     # Shallow water with radial dam break problem, h = hin inside
c     # circle specified in fdisc.f
c
      implicit none

      integer maxmx, maxmy, meqn, mbc, mx, my, maux
      double precision xlower, ylower, dx, dy
      double precision q(1-mbc:maxmx+mbc, 1-mbc:maxmy+mbc, meqn)
      double precision aux(1-mbc:maxmx+mbc, 1-mbc:maxmy+mbc, maux)

      double precision xlow, ylow,win
      integer i,j

      integer blockno, fc2d_clawpack46_get_block

      double precision hin, hout
      common /comic/ hin,hout

      blockno = fc2d_clawpack46_get_block()

      do i=1-mbc,mx+mbc
         xlow = xlower + (i-1.d0)*dx
         do j=1-mbc,my+mbc
            ylow = ylower + (j-1.d0)*dy
            call cellave2(blockno,xlow,ylow,dx,dy,win)
            q(i,j,1) = hin*win + hout*(1.d0-win)
            q(i,j,2) = 0.d0
            q(i,j,3) = 0.d0
            if (meqn .eq. 4) then
               q(i,j,4) = 0.d0
            endif
         end do
      end do
      return
      end


      PROGRAM xchsone
C     driver for routine chsone
      INTEGER NBINS,NPTS
      PARAMETER(NBINS=10,NPTS=2000)
      INTEGER i,ibin,idum,j
      REAL chsq,df,expdev,prob,x,bins(NBINS),ebins(NBINS)
      idum=-15
      do 11 j=1,NBINS
        bins(j)=0.0
11    continue
      do 12 i=1,NPTS
        x=expdev(idum)
        ibin=x*NBINS/3.0+1
        if (ibin.le.NBINS) bins(ibin)=bins(ibin)+1.0
12    continue
      do 13 i=1,NBINS
        ebins(i)=3.0*NPTS/NBINS*exp(-3.0*(i-0.5)/NBINS)
13    continue
      call chsone(bins,ebins,NBINS,0,df,chsq,prob)
      write(*,'(1x,t10,a,t25,a)') 'Expected','Observed'
      do 14 i=1,NBINS
        write(*,'(1x,2f15.2)') ebins(i),bins(i)
14    continue
      write(*,'(/1x,t9,a,e12.4)') 'Chi-squared:',chsq
      write(*,'(1x,t9,a,e12.4)') 'Probability:',prob
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xchsone.for