C     ( Last modified on 23 Dec 2000 at 22:01:38 )
      PROGRAM VE14MA
C
C  Main program for VE14, an algorithm for solving bound-constrained
C  QPs via barrier function methods.
C
C  Nick Gould, Rutherford Appleton Laboratory.
C  March 1992.
C  Modified by Ph. Toint.
C
C  Local variable definitions.

      INTEGER          NMAX  , N, NNZH, LWS, LIWS, IOUT , IPRINT
      INTEGER          ITYPEB, I, J, L, IR , IC  , INPUT, NS, LH
      INTEGER          INSPEC
      CHARACTER * 5    STATE
      CHARACTER * 10   PNAME
      PARAMETER      ( IPRINT = 2, IOUT  = 6 )
CS    REAL             ZERO, OBJF, STOPG, QFVAL
CD    DOUBLE PRECISION ZERO, OBJF, STOPG, QFVAL
      PARAMETER      ( INPUT = 55, INSPEC = 56 )
CTOY  PARAMETER      ( NMAX = 100 )
CMED  PARAMETER      ( NMAX = 1000 )
CBIG  PARAMETER      ( NMAX = 20000 )
CCUS  PARAMETER      ( NMAX = 5000 )
CTOY  PARAMETER      ( LH = 10000  , LWS = 10000  , LIWS = 10000 )
CMED  PARAMETER      ( LH = 100000 , LWS = 100000 , LIWS = 100000 )
CBIG  PARAMETER      ( LH = 300000 , LWS = 600000 , LIWS = 600000 )
CCUS  PARAMETER      ( LH = 200000 , LWS = 300000 , LIWS = 300000 )
CS    PARAMETER      ( ZERO   = 0.0E+0 )
CD    PARAMETER      ( ZERO   = 0.0D+0 )
C
C  Array definitions.
C
      INTEGER          ICNTRL( 4 ), INFORM( 7 )
      INTEGER          IRNH( LH ) , ICNH( LH ) , IWS( LIWS )
CS    REAL             X( NMAX ), G( NMAX ), C( NMAX )
CS    REAL             H( LH ), BND( 2, NMAX ), WS( LWS ), CONTRL( 4 )
CD    DOUBLE PRECISION X( NMAX ), G( NMAX ), C( NMAX )
CD    DOUBLE PRECISION H( LH ), BND( 2, NMAX ), WS( LWS ), CONTRL( 4 )
      LOGICAL          LCNTRL( 2 )
      CHARACTER * 10   VNAME( NMAX )
      REAL             CPU( 2 ), CALLS( 4 )
C
C  Open the Spec file for the method.
C
      OPEN ( INSPEC, FILE = 'VE14.SPC', FORM = 'FORMATTED',
     *      STATUS = 'OLD' )
      REWIND INSPEC
C
C  Read input Spec data.
C
C     ITYPEB indicates the type of barrier used.
C            ITYPEB = 1 is a normal barrier function,
C            ITYPEB = 2 is the Jittorntrum and Osborne variation,
C            ITYPEB = 3 is a Lagrangian barrier function.
C     STOPG  gives the stopping tolerance on the projected gradient
C
      READ ( INSPEC, 1000 ) ITYPEB, STOPG
C
C  Close input file.
C
      CLOSE ( INSPEC )
C
C  Open the relevant file.
C
      OPEN ( INPUT, FILE = 'OUTSDIF.d', FORM = 'FORMATTED',
     *       STATUS = 'OLD' )
      REWIND INPUT
C
C  Set up the data structures necessary to hold the group partially
C  separable function.
C
      CALL USETUP ( INPUT, IOUT, N, X, WS( 1 ), WS( NMAX + 1 ), NMAX )
C
C  Determine the names of the problem and variables.
C
      CALL UNAMES( N, PNAME, VNAME )
C
C  Allocate the bounds.
C
CS    CALL SCOPY ( N, WS( 1 ), 1, BND( 1, 1 ), 2 )
CD    CALL DCOPY ( N, WS( 1 ), 1, BND( 1, 1 ), 2 )
CS    CALL SCOPY ( N, WS( NMAX + 1 ), 1, BND( 2, 1 ), 2 )
CD    CALL DCOPY ( N, WS( NMAX + 1 ), 1, BND( 2, 1 ), 2 )
      DO 10 I = 1, N
         WS( I ) = ZERO
   10 CONTINUE
C
C  Evaluate the constant term, OBJF, of the objective function.
C
      CALL UFN ( N, WS, OBJF )
C
C  Evaluate the linear term of the objective function.
C
      CALL UGR ( N, WS, C )
C
C  Evaluate the Hessian of the objective function at the initial point.
C
      CALL USH ( N, WS, NNZH, LH, H, IRNH, ICNH )
C
C  Remove any zeros.
C
      NS = 0
      DO 20 I = 1, NNZH
         IF ( H( I ) .NE. ZERO ) THEN
            NS = NS + 1
            IRNH( NS ) = IRNH( I )
            ICNH( NS ) = ICNH( I )
            H( NS ) = H( I )
         END IF
   20 CONTINUE
      NNZH = NS
C
C  ------------------- problem set-up complete ----------------------
C
C
C  Set all default values.
C
CS    CALL VE14I ( ICNTRL, CONTRL, LCNTRL )
CD    CALL VE14ID( ICNTRL, CONTRL, LCNTRL )
C
C  Call the optimizer.
C
CS    CALL VE14A ( ITYPEB, IPRINT, STOPG , N , X , BND   ,
CD    CALL VE14AD( ITYPEB, IPRINT, STOPG , N , X , BND   ,
     *             OBJF  , C     , NNZH  , LH, H , IRNH  , ICNH   ,
     *             G     , IWS   , LIWS  , WS( N + 1 )   , LWS - N,
     *             QFVAL , ICNTRL, CONTRL, LCNTRL, INFORM )
      CALL UREPRT ( CALLS, CPU )
C
C  Print details of the solution obtained.
C
      WRITE( IOUT, 2030 ) INFORM( 1 )
      IF ( INFORM( 1 ) .GE. 0 .AND. INFORM( 1 ) .LE. 3 ) THEN
         L = 2
         DO 520 J = 1, 2
            IF ( J .EQ. 1 ) THEN
               IR = 1
               IC = MIN( L, N )
            ELSE
               IF ( IC. LT. N - L ) WRITE( IOUT, 2050 )
               IR = MAX( IC + 1, N - IC + 1 )
               IC = N
            END IF
            DO 510 I = IR, IC
               STATE = ' FREE'
               IF ( ABS( X( I ) - BND( 1, I ) ) .LT. 1.0D-12 )
     *            STATE = 'LOWER'
               IF ( ABS( X( I ) - BND( 2, I ) ) .LT. 1.0D-12 )
     *            STATE = 'UPPER'
               IF ( ABS( BND( 1, I ) - BND( 2, I ) ) .LT. 1.0D-12 )
     *            STATE = 'FIXED'
               WRITE( IOUT, 2040 ) VNAME( I ), STATE, X( I ),
     *                          BND( 1, I ), BND( 2, I ), G( I )
  510       CONTINUE
  520    CONTINUE
      END IF
C
C   Print statistics
C

      WRITE ( IOUT, 2000 ) PNAME, N, ( CALLS( I ), I = 1, 3 ),
     *                     INFORM( 1 ), QFVAL, CPU( 1 ), CPU( 2 )
      CLOSE( INPUT  )
      STOP
C
C   Non executable statements
C
 1000 FORMAT( I10, /, D10.3 )
 2000 FORMAT( /, 24('*'), ' CUTEr statistics ', 24('*') //
     *    ,' Code used               :  VE14',     /
     *    ,' Problem                 :  ', A10,    /
     *    ,' # variables             =      ', I10 /
     *    ,' # objective functions   =        ', F8.2 /
     *    ,' # objective gradients   =        ', F8.2 /
     *    ,' # objective Hessians    =        ', F8.2 /
     *     ' Exit code               =      ', I10 /
     *    ,' Final f                 = ', E15.7 /
     *    ,' Set up time             =      ', 0P, F10.2, ' seconds' /
     *     ' Solve time              =      ', 0P, F10.2, ' seconds' //
     *     66('*') / )
 2030 FORMAT( /, ' Stopping with INFORM( 1 ) = ', I3, //,
     *        ' Solution:', //,
     *        ' name       state     value   ',
     *        '   Lower bound   Upper bound  Dual variable ' )
 2040 FORMAT( 1X, A10, A6, 1P, 4D14.6 )
 2050 FORMAT( ' .          .....  ............',
     *        '  ............  ............  ............ ' )
C
C  End of VE14MA.
C
      END


*deck rad1
      subroutine rad1(aa,aarr1,alpt,arp2,ccr,dfac,fctr2,kcrl,kcru,
     &  lamu,ltot1,ncr,qsum,rk,tol,zcr)
c
c  compute type 1 radial integrals
c
      implicit real*8 (a-h,o-z)
      parameter (a0=0.0d0, a2=2.0d0)
      dimension ccr(*), dfac(*), ncr(*), qsum(ltot1,*), zcr(*)
c
      do 40 kcr=kcrl,kcru
        npi=ncr(kcr)
        alpha=aa+zcr(kcr)
c       # exponential factor from q functions included in dum
        dum=aarr1+zcr(kcr)*arp2/alpha
        if(dum.gt.tol) go to 40
        prd=fctr2*ccr(kcr)*exp(-dum)
        if(rk.eq.a0) then
          t=a0
          do 20 n=1,ltot1-mod(ltot1-1,2),2
            qsum(n,1)=qsum(n,1)+prd*
     &                qcomp(alpha,dfac,npi+n-1,0,t,rk)
   20     continue
        else
          t=alpt/alpha
          do 30 lam=1,lamu
            qsum(lam,lam)=qsum(lam,lam)+prd*
     &                    qcomp(alpha,dfac,npi+lam-1,lam-1,t,rk)
   30     continue
        endif
   40 continue
c
      if(rk.ne.a0) then
        f2lam3=(lamu+lamu-3)
        do 60 lam=lamu-2,1,-1
          do 50 n=lam+2,lamu-mod(lamu-lam,2),2
            qsum(n,lam)=qsum(n,lam+2)+
     &                  (f2lam3/rk)*qsum(n-1,lam+1)
   50     continue
          f2lam3=f2lam3-a2
   60   continue
      endif
      return
      end


*DECK DBESI1
      DOUBLE PRECISION FUNCTION DBESI1 (X)
C***BEGIN PROLOGUE  DBESI1
C***PURPOSE  Compute the modified (hyperbolic) Bessel function of the
C            first kind of order one.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10B1
C***TYPE      DOUBLE PRECISION (BESI1-S, DBESI1-D)
C***KEYWORDS  FIRST KIND, FNLIB, HYPERBOLIC BESSEL FUNCTION,
C             MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DBESI1(X) calculates the double precision modified (hyperbolic)
C Bessel function of the first kind of order one and double precision
C argument X.
C
C Series for BI1        on the interval  0.          to  9.00000E+00
C                                        with weighted error   1.44E-32
C                                         log weighted error  31.84
C                               significant figures required  31.45
C                                    decimal places required  32.46
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, DBSI1E, DCSEVL, INITDS, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  DBESI1
      DOUBLE PRECISION X, BI1CS(17), XMAX, XMIN, XSML, Y, D1MACH,
     1  DCSEVL, DBSI1E
      LOGICAL FIRST
      SAVE BI1CS, NTI1, XMIN, XSML, XMAX, FIRST
      DATA BI1CS(  1) / -.1971713261 0998597316 1385032181 49 D-2     /
      DATA BI1CS(  2) / +.4073488766 7546480608 1553936520 14 D+0     /
      DATA BI1CS(  3) / +.3483899429 9959455866 2450377837 87 D-1     /
      DATA BI1CS(  4) / +.1545394556 3001236038 5984010584 89 D-2     /
      DATA BI1CS(  5) / +.4188852109 8377784129 4588320041 20 D-4     /
      DATA BI1CS(  6) / +.7649026764 8362114741 9597039660 69 D-6     /
      DATA BI1CS(  7) / +.1004249392 4741178689 1798080372 38 D-7     /
      DATA BI1CS(  8) / +.9932207791 9238106481 3712980548 63 D-10    /
      DATA BI1CS(  9) / +.7663801791 8447637275 2001716813 49 D-12    /
      DATA BI1CS( 10) / +.4741418923 8167394980 3880919481 60 D-14    /
      DATA BI1CS( 11) / +.2404114404 0745181799 8631720320 00 D-16    /
      DATA BI1CS( 12) / +.1017150500 7093713649 1211007999 99 D-18    /
      DATA BI1CS( 13) / +.3645093565 7866949458 4917333333 33 D-21    /
      DATA BI1CS( 14) / +.1120574950 2562039344 8106666666 66 D-23    /
      DATA BI1CS( 15) / +.2987544193 4468088832 0000000000 00 D-26    /
      DATA BI1CS( 16) / +.6973231093 9194709333 3333333333 33 D-29    /
      DATA BI1CS( 17) / +.1436794822 0620800000 0000000000 00 D-31    /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  DBESI1
      IF (FIRST) THEN
         NTI1 = INITDS (BI1CS, 17, 0.1*REAL(D1MACH(3)))
         XMIN = 2.0D0*D1MACH(1)
         XSML = SQRT(4.5D0*D1MACH(3))
         XMAX = LOG (D1MACH(2))
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS(X)
      IF (Y.GT.3.0D0) GO TO 20
C
      DBESI1 = 0.D0
      IF (Y.EQ.0.D0)  RETURN
C
      IF (Y .LE. XMIN) CALL XERMSG ('SLATEC', 'DBESI1',
     +   'ABS(X) SO SMALL I1 UNDERFLOWS', 1, 1)
      IF (Y.GT.XMIN) DBESI1 = 0.5D0*X
      IF (Y.GT.XSML) DBESI1 = X*(0.875D0 + DCSEVL (Y*Y/4.5D0-1.D0,
     1  BI1CS, NTI1))
      RETURN
C
 20   IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'DBESI1',
     +   'ABS(X) SO BIG I1 OVERFLOWS', 2, 2)
C
      DBESI1 = EXP(Y) * DBSI1E(X)
C
      RETURN
      END


      SUBROUTINE KENDL2(TAB,I,J,IP,JP,TAU,Z,PROB)
      DIMENSION TAB(IP,JP)
      EN1=0.
      EN2=0.
      S=0.
      NN=I*J
      POINTS=TAB(I,J)
      DO 12 K=0,NN-2
        KI=K/J
        KJ=K-J*KI
        POINTS=POINTS+TAB(KI+1,KJ+1)
        DO 11 L=K+1,NN-1
          LI=L/J
          LJ=L-J*LI
          M1=LI-KI
          M2=LJ-KJ
          MM=M1*M2
          PAIRS=TAB(KI+1,KJ+1)*TAB(LI+1,LJ+1)
          IF(MM.NE.0)THEN
            EN1=EN1+PAIRS
            EN2=EN2+PAIRS
            IF(MM.GT.0)THEN
              S=S+PAIRS
            ELSE
              S=S-PAIRS
            ENDIF
          ELSE
            IF(M1.NE.0)EN1=EN1+PAIRS
            IF(M2.NE.0)EN2=EN2+PAIRS
          ENDIF
11      CONTINUE
12    CONTINUE
      TAU=S/SQRT(EN1*EN2)
      VAR=(4.*POINTS+10.)/(9.*POINTS*(POINTS-1.))
      Z=TAU/SQRT(VAR)
      PROB=ERFCC(ABS(Z)/1.4142136)
      RETURN
      END


C**********************************************************************
C     SUBROUTINE INTRP2() PERFORMS BICUBIC INTERPOLATION ON A TWO
C     DIMENSIONAL EQUALLY SPACED GRID.  RETURNS INTERPOLATED VALUE
C     AND FIRST AND SECOND PARTIAL DERIVATIVES IN Z, ZX, ZXX, ZY, ZYY,
C     ZXY. INTERPOLATION INSURES CONTINUOUS Y AND YX ACROSS GRIDPOINTS.
C     USES CUBIC EXTRAPOLATION IF BEYOND GRID RANGE (DANGEROUS!).
C
C     USES BCUCOF(), BCUINT() FROM NUMERICAL RECIPES, P.99
C     *** NOTE: 2ND DERIVATIVES ADDED 5 JULY 1990 ***
C     *** NOTE: CORRECTED FOR XMIN, YMIN .NE. 0 23 SEP 1993 ***
C     AUTHOR: R. JONES  4 JUNE 1990
C**********************************************************************

      SUBROUTINE INTRP2(X,XMIN,XMAX,M,Y,YMIN,YMAX,N,GRID,
     &                  Z,ZX,ZY,ZXX,ZYY,ZXY)

      IMPLICIT DOUBLE PRECISION (A-H,K-L,O-Z)
      DIMENSION GRID( 0:M, 0:N )
      DIMENSION F(4),F1(4),F2(4),F12(4),C(4,4)

      H  = ( XMAX - XMIN ) / M
      XX = ( X    - XMIN ) / H
      MM = INT ( XX )
      K  = ( YMAX - YMIN ) / N
      YY = ( Y    - YMIN ) / K
      NN = INT ( YY )

C     Next line insures all elements of GRID used are in range 0-M,N
      MM = MAX ( 1 , MIN ( M - 2, MM ) )
      XR = XX - MM
      NN = MAX ( 1 , MIN ( N - 2, NN ) )
      YR = YY - NN

C     Assemble information needed by BCUINT()
      XL = MM * H + XMIN
      XU = XL + H
      YL = NN * K + YMIN
      YU = YL + K
      DO  J = NN, NN+1
       DO  I = MM, MM+1
         II = 1 + (I-MM) + 3 * (J-NN)
         IF ( II .EQ. 5 ) II = 3
         F(II)   =  GRID(I,J)
         F1(II)  = (GRID(I+1,J) - GRID(I-1,J)) / (2D0 * H)
         F2(II)  = (GRID(I,J+1) - GRID(I,J-1)) / (2D0 * K)
         F12(II) = (GRID(I+1,J+1) - GRID(I+1,J-1) - GRID(I-1,J+1)
     &           +  GRID(I-1,J-1)) / ( 4D0 * H * K )
       END DO
      END DO

      CALL BCUINT( F, F1, F2, F12, XL, XU, YL, YU, X, Y, Z, ZX, ZY,
     &             ZXX, ZYY, ZXY )

      RETURN
      END

      SUBROUTINE BCUINT(Y,Y1,Y2,Y12,X1L,X1U,X2L,X2U,X1,X2,A,A1,A2,
     &                  A11,A22,A12)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION Y(4),Y1(4),Y2(4),Y12(4),C(4,4)

      CALL BCUCOF(Y,Y1,Y2,Y12,X1U-X1L,X2U-X2L,C)
      T = (X1 - X1L) / (X1U - X1L)
      U = (X2 - X2L) / (X2U - X2L)
      A  = 0D0
      A1 = 0D0
      A2 = 0D0
      A11 = 0D0
      A22 = 0D0
      DO I = 4, 1, -1
         A   = T * A  + ((C(I,4)*U + C(I,3))*U + C(I,2))*U + C(I,1)
         A2  = T * A2 + (3D0*C(I,4)*U + 2D0*C(I,3))*U + C(I,2)
         A22 = T * A22 + 6D0*C(I,4)*U + 2D0*C(I,3)
         A1  = U * A1 + (3D0*C(4,I)*T + 2D0*C(3,I))*T + C(2,I)
         A11 = U * A11 + 6D0*C(4,I)*T + 2D0*C(3,I)
      END DO
      A12 =          C(2,2) + U*(2D0*C(2,3) + 3D0*C(2,4)*U) +
     &      T * (2D0*C(3,2) + U*(4D0*C(3,3) + 6D0*C(3,4)*U) +
     &      T * (3D0*C(4,2) + U*(6D0*C(4,3) + 9D0*C(4,4)*U)))
      A1  = A1  /  (X1U - X1L)
      A11 = A11 / ((X1U - X1L) * (X1U - X1L))
      A2  = A2  /  (X2U - X2L)
      A22 = A22 / ((X2U - X2L) * (X2U - X2L))
      A12 = A12 / ((X1U - X1L) * (X2U - X2L))
      RETURN
      END

      SUBROUTINE BCUCOF(Y,Y1,Y2,Y12,D1,D2,C)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION Y(4),Y1(4),Y2(4),Y12(4),C(4,4),CL(16),X(16),WT(16,16)

      DATA WT/1,0,-3,2,4*0,-3,0,9,-6,2,0,-6,4,8*0,3,0,-9,6,-2,0,6,-4,
     &  10*0,9,-6,2*0,-6,4,2*0,3,-2,6*0,-9,6,2*0,6,-4,
     &  4*0,1,0,-3,2,-2,0,6,-4,1,0,-3,2,8*0,-1,0,3,-2,1,0,-3,2,
     &  10*0,-3,2,2*0,3,-2,6*0,3,-2,2*0,-6,4,2*0,3,-2,
     &  0,1,-2,1,5*0,-3,6,-3,0,2,-4,2,9*0,3,-6,3,0,-2,4,-2,
     &  10*0,-3,3,2*0,2,-2,2*0,-1,1,6*0,3,-3,2*0,-2,2,
     &  5*0,1,-2,1,0,-2,4,-2,0,1,-2,1,9*0,-1,2,-1,0,1,-2,1,
     &  10*0,1,-1,2*0,-1,1,6*0,-1,1,2*0,2,-2,2*0,-1,1/

      D1D2 = D1 * D2
      DO I = 1, 4
         X(I)    = Y(I)
         X(I+4)  = Y1(I)  * D1
         X(I+8)  = Y2(I)  * D2
         X(I+12) = Y12(I) * D1D2
      END DO
      DO I = 1, 16
         XX = 0D0
         DO K = 1, 16
            XX = XX + WT(I,K) * X(K)
         END DO
         CL(I) = XX
      END DO
      L = 0
      DO I = 1, 4
         DO J = 1, 4
            L = L + 1
            C(I,J) = CL(L)
         END DO
      END DO

      RETURN
      END


!-----------------------------------------------------------------------
subroutine sub_rhs_tlm
!-----------------------------------------------------------------------
  use mod_variables
  implicit none
!
  integer :: ic,jc
  real(8) :: dci,dci2,r12,dc12,dc12al
  real(8) :: xibl,yibl
!
!=====Base flow
  real(8) :: uxc_b,uxm_b,uxp_b,uym_b,uyp_b
  real(8) :: vyc_b,vxm_b,vxp_b,vym_b,vyp_b
  real(8) :: uxmm_b,uxpp_b,uymm_b,uyc_b,uypp_b
  real(8) :: vxmm_b,vxc_b,vxpp_b,vymm_b,vypp_b
!
  real(8) :: dudx1_b,dudy1_b
  real(8) :: dvdx1_b,dvdy1_b
  real(8) :: dudx2_b,dudy2_b
  real(8) :: dvdx2_b,dvdy2_b
!
  real(8) :: abs_uxc_b,abs_uyc_b
  real(8) :: abs_vxc_b,abs_vyc_b
!
!=====Disturbance
  real(8) :: uxc,uxm,uxp,uym,uyp
  real(8) :: vyc,vxm,vxp,vym,vyp
  real(8) :: uxmm,uxpp,uymm,uyc,uypp
  real(8) :: vxmm,vxc,vxpp,vymm,vypp
!
  real(8) :: dudx1,dudy1
  real(8) :: dvdx1,dvdy1
  real(8) :: dudx2,dudy2
  real(8) :: dvdx2,dvdy2
!
  real(8) :: abs_uxc,abs_uyc
  real(8) :: abs_vxc,abs_vyc
!
  real(8) :: uold(imx1,jmax)
  real(8) :: vold(imax,jmx1)
!-----------------------------------------------------------------------
!
!
!---> Coefficients
  r12    = 1.d0/12.d0
  dci    = 1.d0/dx
  dci2   = dci**2/Re
  dc12   = dci*r12
  dc12al = dc12*3.d0
!
!
!-----------------------------------------------------------------------
!---- x-direction
!-----------------------------------------------------------------------
    do jc=3,jmax-2
    do ic=3,imx1-2
!
!=====Base flow
      uxm_b  = ustg_b(ic-1,jc)
      uxp_b  = ustg_b(ic+1,jc)
      uym_b  = ustg_b(ic,jc-1)
      uyp_b  = ustg_b(ic,jc+1)
!
      uxmm_b = ustg_b(ic-2,jc)
      uxpp_b = ustg_b(ic+2,jc)
      uymm_b = ustg_b(ic,jc-2)
      uypp_b = ustg_b(ic,jc+2)
!
      uxc_b  = ustg_b(ic,jc)
      vxc_b  = 0.25d0*(vstg_b(ic  ,jc+1)+vstg_b(ic  ,jc) &
                      +vstg_b(ic-1,jc+1)+vstg_b(ic-1,jc))
!
      dudx1_b = dc12  *(uxmm_b-8.d0*uxm_b           +8.d0*uxp_b-uxpp_b)
      dudy1_b = dc12  *(uymm_b-8.d0*uym_b           +8.d0*uyp_b-uypp_b)
      dudx2_b = dc12al*(uxmm_b-4.d0*uxm_b+6.d0*uxc_b-4.d0*uxp_b+uxpp_b)
      dudy2_b = dc12al*(uymm_b-4.d0*uym_b+6.d0*uxc_b-4.d0*uyp_b+uypp_b)
!
      abs_uxc_b = dabs(uxc_b)
      abs_vxc_b = dabs(vxc_b)
!
!---- Inviscid term
      udlt_b(ic,jc) = (uxc_b*dudx1_b+abs_uxc_b*dudx2_b) &
                     +(vxc_b*dudy1_b+abs_vxc_b*dudy2_b)
!---- Viscous term
      udlt_b(ic,jc) = udlt_b(ic,jc)-(uxp_b-2.d0*uxc_b+uxm_b)*dci2 &
                                   -(uyp_b-2.d0*uxc_b+uym_b)*dci2
!---- Pressure gradient term
      udlt_b(ic,jc) = udlt_b(ic,jc)+(pcnt_b(ic,jc)-pcnt_b(ic-1,jc))*dci
!
!
!=====Disturbance
      uxm  = ustg(ic-1,jc)
      uxp  = ustg(ic+1,jc)
      uym  = ustg(ic,jc-1)
      uyp  = ustg(ic,jc+1)
!
      uxmm = ustg(ic-2,jc)
      uxpp = ustg(ic+2,jc)
      uymm = ustg(ic,jc-2)
      uypp = ustg(ic,jc+2)
!
      uxc  = ustg(ic,jc)
      vxc  = 0.25d0*(vstg(ic  ,jc+1)+vstg(ic  ,jc) &
                    +vstg(ic-1,jc+1)+vstg(ic-1,jc))
!
      dudx1 = dc12  *(uxmm-8.d0*uxm         +8.d0*uxp-uxpp)
      dudy1 = dc12  *(uymm-8.d0*uym         +8.d0*uyp-uypp)
      dudx2 = dc12al*(uxmm-4.d0*uxm+6.d0*uxc-4.d0*uxp+uxpp)
      dudy2 = dc12al*(uymm-4.d0*uym+6.d0*uxc-4.d0*uyp+uypp)
!
      abs_uxc   = dsign(1.d0,uxc_b)*uxc
      abs_vxc   = dsign(1.d0,vxc_b)*vxc
!
!---- Inviscid term
      udlt(ic,jc) = (uxc*dudx1_b+uxc_b*dudx1+abs_uxc*dudx2_b+abs_uxc_b*dudx2) &
                   +(vxc*dudy1_b+vxc_b*dudy1+abs_vxc*dudy2_b+abs_vxc_b*dudy2)
!---- Viscous term
      udlt(ic,jc) = udlt(ic,jc)-(uxp-2.d0*uxc+uxm)*dci2 &
                               -(uyp-2.d0*uxc+uym)*dci2
!---- Pressure gradient term
      udlt(ic,jc) = udlt(ic,jc)+(pcnt(ic,jc)-pcnt(ic-1,jc))*dci
!
    enddo
    enddo
!
!
!-----------------------------------------------------------------------
!---- y-direction
!-----------------------------------------------------------------------
    do jc=3,jmx1-2
    do ic=3,imax-2
!
!=====Base flow
      vxm_b  = vstg_b(ic-1,jc)
      vxp_b  = vstg_b(ic+1,jc)
      vym_b  = vstg_b(ic,jc-1)
      vyp_b  = vstg_b(ic,jc+1)
!
      vxmm_b = vstg_b(ic-2,jc)
      vxpp_b = vstg_b(ic+2,jc)
      vymm_b = vstg_b(ic,jc-2)
      vypp_b = vstg_b(ic,jc+2)
!
      uyc_b  = 0.25d0*(ustg_b(ic+1,jc  )+ustg_b(ic,jc  ) &
                      +ustg_b(ic+1,jc-1)+ustg_b(ic,jc-1))
      vyc_b  = vstg_b(ic,jc)
!
      dvdx1_b = dc12  *(vxmm_b-8.d0*vxm_b           +8.d0*vxp_b-vxpp_b)
      dvdy1_b = dc12  *(vymm_b-8.d0*vym_b           +8.d0*vyp_b-vypp_b)
      dvdx2_b = dc12al*(vxmm_b-4.d0*vxm_b+6.d0*vyc_b-4.d0*vxp_b+vxpp_b)
      dvdy2_b = dc12al*(vymm_b-4.d0*vym_b+6.d0*vyc_b-4.d0*vyp_b+vypp_b)
!
      abs_uyc_b = dabs(uyc_b)
      abs_vyc_b = dabs(vyc_b)
!
!---- Inviscid term
      vdlt_b(ic,jc) = (uyc_b*dvdx1_b+abs_uyc_b*dvdx2_b) &
                     +(vyc_b*dvdy1_b+abs_vyc_b*dvdy2_b)
!---- Viscous term
      vdlt_b(ic,jc) = vdlt_b(ic,jc)-(vxp_b-2.d0*vyc_b+vxm_b)*dci2 &
                                   -(vyp_b-2.d0*vyc_b+vym_b)*dci2
!---- Pressure gradient term
      vdlt_b(ic,jc) = vdlt_b(ic,jc)+(pcnt_b(ic,jc)-pcnt_b(ic,jc-1))*dci
!
!
!=====Disturbance
      vxm  = vstg(ic-1,jc)
      vxp  = vstg(ic+1,jc)
      vym  = vstg(ic,jc-1)
      vyp  = vstg(ic,jc+1)
!
      vxmm = vstg(ic-2,jc)
      vxpp = vstg(ic+2,jc)
      vymm = vstg(ic,jc-2)
      vypp = vstg(ic,jc+2)
!
      uyc  = 0.25d0*(ustg(ic+1,jc  )+ustg(ic,jc  ) &
                    +ustg(ic+1,jc-1)+ustg(ic,jc-1))
      vyc  = vstg(ic,jc)
!
      dvdx1 = dc12  *(vxmm-8.d0*vxm         +8.d0*vxp-vxpp)
      dvdy1 = dc12  *(vymm-8.d0*vym         +8.d0*vyp-vypp)
      dvdx2 = dc12al*(vxmm-4.d0*vxm+6.d0*vyc-4.d0*vxp+vxpp)
      dvdy2 = dc12al*(vymm-4.d0*vym+6.d0*vyc-4.d0*vyp+vypp)
!
      abs_uyc = dsign(1.d0,uyc_b)*uyc
      abs_vyc = dsign(1.d0,vyc_b)*vyc
!
!---- Inviscid term
      vdlt(ic,jc) = (uyc*dvdx1_b+uyc_b*dvdx1+abs_uyc*dvdx2_b+abs_uyc_b*dvdx2) &
                   +(vyc*dvdy1_b+vyc_b*dvdy1+abs_vyc*dvdy2_b+abs_vyc_b*dvdy2)
!---- Viscous term
      vdlt(ic,jc) = vdlt(ic,jc)-(vxp-2.d0*vyc+vxm)*dci2 &
                               -(vyp-2.d0*vyc+vym)*dci2
!---- Pressure gradient term
      vdlt(ic,jc) = vdlt(ic,jc)+(pcnt(ic,jc)-pcnt(ic,jc-1))*dci
!
  enddo
  enddo
!
!
  uold(1:imx1,1:jmax) = ustg(1:imx1,1:jmax)
  vold(1:imax,1:jmx1) = vstg(1:imax,1:jmx1)
  ustg(1:imx1,1:jmax) = 0.d0
  vstg(1:imax,1:jmx1) = 0.d0
!
!
  do jc=3,jmx1-2
  do ic=3,imx1-2
    if(jc==jmx1-2) goto 10
    xibl = dble(min0(iblk(ic-1,jc),iblk(ic,jc)))
    ustg_b(ic,jc) = ustg_b(ic,jc)-dt*udlt_b(ic,jc)*xibl
    ustg  (ic,jc) = uold  (ic,jc)-dt*udlt  (ic,jc)*xibl
 10 continue
    if(ic==imx1-2) goto 20
    yibl = dble(min0(iblk(ic,jc-1),iblk(ic,jc)))
    vstg_b(ic,jc) = vstg_b(ic,jc)-dt*vdlt_b(ic,jc)*yibl
    vstg  (ic,jc) = vold  (ic,jc)-dt*vdlt  (ic,jc)*yibl
 20 continue
  enddo
  enddo
!
  return
end subroutine sub_rhs_tlm
!-----------------------------------------------------------------------


SUBROUTINE rhsFreeSurface3D_SWENSE(t,Wavefield,g,rhsE,rhsP,Nx,Ny)
!
USE Precision
USE Constants
USE DataTypes
IMPLICIT NONE
INTEGER :: Nx,Ny
REAL(KIND=long) :: g,t
REAL(KIND=long), DIMENSION(Nx,Ny) :: rhsE, rhsP ! E, Ex, Ey, P, Px, Py, W,
!REAL(KIND=long), DIMENSION(Nx,Ny) :: E_I,Ex_I,Ey_I,Et_I,Px_I,Py_I,W_I,Pt_I
TYPE(Wavefield_FS) :: Wavefield
! Local variables
!$$$$$$ REAL(KIND=long), DIMENSION(:,:), ALLOCATABLE :: PxS_I , PyS_I
REAL(KIND=long), DIMENSION(Nx,Ny) :: PtS_I , PxS_I , PyS_I

IF (Nx==1) THEN
!$$$$$$     ALLOCATE(PyS_I(Nx,Ny))
  	! Surfacic quantities for incident wave field
	PyS_I = Wavefield%Py_I_s + (Wavefield%Ey+Wavefield%Ey_I)*Wavefield%Pz_I_s
    !
	rhsE = - (Wavefield%Ey+Wavefield%Ey_I)*(Wavefield%Py+PyS_I) &
    	   + (Wavefield%W+Wavefield%Pz_I_s)*(one + (Wavefield%Ey+Wavefield%Ey_I)**2) - Wavefield%Et_I                  ! kinematic FS BC
    !
    ! Surfacic quantities for incident wave field
    PtS_I = Wavefield%Pt_I_s + (rhsE+Wavefield%Et_I)*Wavefield%Pz_I_s
    !
	rhsP = -g*(Wavefield%E+Wavefield%E_I) - half*((Wavefield%Py+PyS_I)**2 &
    	   -(Wavefield%W+Wavefield%Pz_I_s)**2*(one + (Wavefield%Ey+Wavefield%Ey_I)**2)) - PtS_I  ! dynamic FS BC!
!$$$$$$     DEALLOCATE(PyS_I)
ELSE IF (Ny==1) THEN
!$$$$$$     ALLOCATE(PxS_I(Nx,Ny))
  	! Surfacic quantities for incident wave field
    PxS_I = Wavefield%Px_I_s + (Wavefield%Ex+Wavefield%Ex_I)*Wavefield%Pz_I_s
    !
	rhsE = -(Wavefield%Ex+Wavefield%Ex_I)*(Wavefield%Px+PxS_I) &
    	   +(Wavefield%W+Wavefield%Pz_I_s)*(one + (Wavefield%Ex+Wavefield%Ex_I)**2) - Wavefield%Et_I                 ! kinematic FS BC
    !
    ! Surfacic quantities for incident wave field
    PtS_I = Wavefield%Pt_I_s + (rhsE+Wavefield%Et_I)*Wavefield%Pz_I_s
    !
	rhsP = -g*(Wavefield%E+Wavefield%E_I) - half*((Wavefield%Px+PxS_I)**2 &
    	   -(Wavefield%W+Wavefield%Pz_I_s)**2*(one + (Wavefield%Ex+Wavefield%Ex_I)**2)) - PtS_I  ! dynamic FS BC!
!$$$$$$     DEALLOCATE(PxS_I)
ELSE
!$$$$$$     ALLOCATE(PxS_I(Nx,Ny),PyS_I(Nx,Ny))
  	! Surfacic quantities for incident wave field
	PxS_I = Wavefield%Px_I_s + (Wavefield%Ex+Wavefield%Ex_I)*Wavefield%Pz_I_s
    PyS_I = Wavefield%Py_I_s + (Wavefield%Ey+Wavefield%Ey_I)*Wavefield%Pz_I_s
    !
	rhsE = -(Wavefield%Ex+Wavefield%Ex_I)*(Wavefield%Px+PxS_I)-(Wavefield%Ey+Wavefield%Ey_I)*(Wavefield%Py+PyS_I) &
    	+ (Wavefield%W+Wavefield%Pz_I_s)*(one + (Wavefield%Ex+Wavefield%Ex_I)**2 + (Wavefield%Ey+Wavefield%Ey_I)**2) &
        - Wavefield%Et_I            ! kinematic FS BC
    !
    ! Surfacic quantities for incident wave field
    PtS_I = Wavefield%Pt_I_s + (rhsE+Wavefield%Et_I)*Wavefield%Pz_I_s
    !
	rhsP = -g*(Wavefield%E+Wavefield%E_I) - half*((Wavefield%Px+PxS_I)**2 + (Wavefield%Py+PyS_I)**2 &
    	- (Wavefield%W+Wavefield%Pz_I_s)**2*(one + (Wavefield%Ex+Wavefield%Ex_I)**2  &
        + (Wavefield%Ey+Wavefield%Ey_I)**2)) - PtS_I       ! dynamic FS BC!
!$$$$$$     DEALLOCATE(PxS_I,PyS_I)
ENDIF

END SUBROUTINE rhsFreeSurface3D_SWENSE


      SUBROUTINE PREP_SECT2_INT(JS2,NVAL,IB,ID,MINA)
C
C        MAY     2000   LAWRENCE   GSC/TDL   ORIGINAL CODING
C        JANUARY 2001   GLAHN      REMOVED MAXA; COMMENTS
C        JANUARY 2001   GLAHN/LAWRENCE CHANGED 10**IB TO 2**IB;
C                                  CHANGED JS2(K)*JE TO JS2(K)/JE
C        JANAURY 2001   LAWRENCE   CHANGED JE=2**IB TO JE=2**(-IB)
C                                  AND NOW MULTIPLY THE VALUES IN
C                                  JS2( ) BY JE INSTEAD OF DIVIDING
C                                  BY IT.
C        NOVEMBER 2001   GLAHN     COMMENT ABOUT IB
C
C        PURPOSE
C            PREPARES THE LOCAL DATA TO BE
C            PACKED USING THE SIMPLE PACKING METHOD.  THE
C            PREPARATION OF THE DATA ENCOMPASSES MULTIPLYING
C            ALL OF THE DATA ELEMENTS IN THE FIELD BY
C            THE DECIMAL SCALING FACTOR, REMOVING THE MINIMUM
C            VALUE, AND DIVIDING ALL OF THE DATA ELEMENTS
C            IN THE FIELD BY THE BINARY SCALING FACTOR.
C
C        DATA SET USE
C           NONE
C
C        VARIABLES
C              JS2(K) = CONTAINS THE LOCAL DATA TO BE PACKED USING
C                       THE SIMPLE PACKING METHOD IN THE LOCAL
C                       USE SECTION OF THE GRIB2 MESSAGE (K=1,NVAL).
C                       (INPUT)
C                NVAL = THE NUMBER OF VALUES IN JS2( ).  (INPUT)
C                  IB = THE BINARY SCALING FACTOR.  THIS IS
C                       0 IN THE CALLING PROGRAM PK_SECT2, AND
C                       HAS NO EFFECT ON THE RESULT.  (INPUT)
C                  ID = THE DECIMAL SCALING FACTOR.  (INPUT)
C                MINA = THE FIELD MINIMUM VALUE.  (OUTPUT)
C
C             LOCAL VARIABLES
C                  JD = THE DECIMAL MULTIPLICATION FACTOR, 10**ID.
C                  JE = THE BINARY MULTIPLICATION FACTOR, 2**IE.
C                   K = LOOP INDEXING VARIABLE.
C
C        NON SYSTEM SUBROUTINES CALLED
C           NONE
C
      DIMENSION JS2(NVAL)
C
C     SCALE THE DATA FIELD BY THE DECIMAL SCALING FACTOR.
C
      IF(ID.NE.0)THEN
         JD=10**ID
C
         DO 10 K=1,NVAL
            JS2(K)=JS2(K)*JD
 10      CONTINUE
C
      ENDIF
C
C        FIND THE MINIMUM OF THE DATA FIELD.
      MINA=JS2(1)
C
      DO 20 K=2,NVAL
C
         IF(JS2(K).LT.MINA)THEN
            MINA=JS2(K)
         ENDIF
C
 20   CONTINUE
C
C        SUBTRACT OUT THE MINIMUM FROM THE DATA
C        FIELD.
C
      DO 30 K=1,NVAL
         JS2(K)=JS2(K)-MINA
 30   CONTINUE
C
C        MULTIPLY THE DATA FIELD BY THE BINARY
C        SCALING FACTOR.
C
      IF(IB.NE.0)THEN
         JE=2**(-IB)
C
         DO 40 K=1,NVAL
            JS2(K)=JS2(K)*JE
 40      CONTINUE
C
      ENDIF
C
      RETURN
      END


c=======================================================================
c
c     subroutine ALLOCTEST
c
c     Max. parameters for Allocation strategies
c       - Max. target return
c       - Max. relative targer return
c       - Min. volatility
c       - Min. VaR
c       - Min. CVaR
c
c-----------------------------------------------------------------------
      SUBROUTINE alloctest ( n, cov, rho, rhob, alpha,
     &                       neq, nin, ccst, bcst, cinf, csup,
     &                       iwork, dwork,
     &                       targetmax, deltamax,
     &                       volmin, varmin, cvarmin,
     &                       info)
c-----------------------------------------------------------------------
c
c     INPUT
c       n         : portfolio size                               integer
c       cov       : covariance matrix (n*n)                       double
c       rho       : mean returns vector (n)                       double
c       rhob      : mean return of index                          double
c       alpha     : confidence level parameter (0<alpha<1)        double
c       neq       : number equality constraints                  integer
c       nin       : number inequality constraints                integer
c       ccst      : matrix of constraints (nasset*(neq+nin))      double
c       bcst      : vector initial of constraints (neq+nin)       double
c       cinf      : lower bound (n)                               double
c       csup      : upper bound (n)                               double
c
c     WORKSPACE
c       iwork     : 4*n + 2*nin + neq + 1                        integer
c       dwork     : n*(4*n + 16) + 3*nin + neq                    double
c
c     OUTPUT
c       targetmax : maximum target return (MV)                    double
c       deltamax  : maximum relative target return (IT)           double
c       volmin    : minimum volatility                            double
c       varmin    : minimum Value-at-Risk (VaR)                   double
c       cvarmin   : minimum Conditional Value-at-Risk (CVaR)      double
c       info      : diagnostic argument                          integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, info, neq, nin
      DOUBLE PRECISION rhob, alpha, targetmax, deltamax, volmin, varmin,
     &                 cvarmin
      DOUBLE PRECISION cov(*), rho(*), cinf(*), csup(*), ccst(*),bcst(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER i, piw, pdcov, pdrho, pdw, pdlagr, pdwopt, infotmp,
     &        pisdp, pdsdp
      DOUBLE PRECISION a, sum, mean, p, q, zc, ZERO, PI, EPS
      PARAMETER (ZERO = 0.D0, PI = 3.1415926535898, EPS = 1.D-15)
c
c     external functions
      DOUBLE PRECISION dinvnr
      EXTERNAL dinvnr
c
c     external subroutines
      EXTERNAL IMX, IVX, YV, qp, OVTMCV, EXARET, testsdp
c
c-----------------------------------------------------------------------
c
c     initializations
      info = 0
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      piw  = 1
c     piw  : pointer for QP workspaces (3*n + 2*nin + neq + 1)
      pisdp = piw + ( 3*n + 2*nin + neq + 1 )
c     pisdp  : pointer for TESTSDP (n)
c
c     Total size of iwork array = 4*n + 2*nin + neq + 1
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdcov  = 1
c     pdcov  : pointer for cov. matrix(n*n)
      pdrho  = pdcov + ( n*n )
c     pdrho  : pointer for vector rho, so (n) more
      pdw    = pdrho +( n )
c     pdw    : pointer for QP workspaces (n*n + 6*n + 2*nin)
      pdlagr = pdw + ( n*n + 6*n + 2*nin )
c     pdlagr : pointer for Lagrange multiplier, (n + nin + neq)
      pdwopt = pdlagr + ( n + nin + neq )
c     pdwopt : pointer for wopt, (n)
      pdsdp = pdwopt + ( n )
c     pdsdp : pointer for TESTSDP (n*(2*n + 7))
c
c     Total size of dwork array = n*n
c                               + n
c                               + n*n + 6*n + 2*nin
c                               + n + nin + neq
c                               + n
c                               + n*(2*n + 7)
c                              =  n*(4*n + 16) + 3*nin + neq
c
c-----------------------------------------------------------------------
c
c     initialize quadratic part to zero
      CALL IMX ( n, n, dwork(pdcov), ZERO )
c
c     initialize linear part to -rho
      a = -1.0
      CALL PVX ( n, rho, a, dwork(pdrho) )
c
c     quadratic solver: min[-rho'*w]
      CALL qp ( n, dwork(pdcov), dwork(pdrho),
     &          neq, nin, ccst, bcst, cinf, csup,
     &          iwork(piw), dwork(pdw),
     &          dwork(pdlagr), dwork(pdwopt), infotmp )
      IF (infotmp .LT. 0) info = infotmp
c
c     max. target
      sum = 0.0
      DO i = 1,n
        sum = sum + rho(i)*dwork(pdwopt+i-1)
      ENDDO
      targetmax = sum
      deltamax = targetmax - rhob
c
c     initialize linear part to -rho
      CALL IVX ( n, dwork(pdrho), ZERO )
c
c     covariance matrix SDP test
      CALL testsdp (n, cov, iwork(pisdp), dwork(pdsdp), infotmp)
      IF (infotmp .NE. 0) THEN
         info = -108
         RETURN
      ENDIF
c
c     quadratic solver: min[w'*cov*w]
      CALL qp ( n, cov, dwork(pdrho),
     &          neq, nin, ccst, bcst, cinf, csup,
     &          iwork(piw), dwork(pdw),
     &          dwork(pdlagr), dwork(pdwopt), infotmp )
      IF (infotmp .LT. 0) info = infotmp
c
c     sqrt[w'*cov*w] (portfolio volatility)
      CALL OVTMCV ( n, cov, dwork(pdwopt), volmin)
      volmin = SQRT(volmin)
c
c     mean return
      CALL EXARET ( n, rho, dwork(pdwopt), mean, infotmp )
c
c     test if: 0 < alpha < 1
      IF ((alpha .LT. EPS).OR.(alpha .GT. (1.0-EPS))) THEN
        info = -102
        RETURN
      ENDIF
c
c     computing inverse of the N(0,1) cumulative distribution
c     call the function dinvnr(p,q)
      p = alpha
      q = 1. - p
      zc = dinvnr(p,q)
c
c     computing Normal -VaR := max[0, min(1, -zc*volatility - mean)]
      varmin = - volmin * zc + mean
      varmin = MIN(varmin, 1.)
      varmin = MAX(varmin, -1.)
c
c     coeff := [sqrt(2*pi)*exp[(zc/2)^2]*(1-alpha)]^(-1)
      zc = SQRT(2.0*PI)*EXP(((zc*zc)/4.0))*(1.0 - alpha)
      zc = 1.0/zc
c
c     computing Normal Conditional Value-at-Risk
c     CVaR := max[0, min(1, -coeff*volatility - mean)]
      cvarmin = - volmin * zc + mean
      cvarmin = MIN(cvarmin, 1.)
      cvarmin = MAX(cvarmin, -1.)
      RETURN
      END


c ----------------------------------------------------------------------

c     this subroutine computes the local energy and potential energy
c     of a configuration.

c ----------------------------------------------------------------------

      subroutine local(q, vloc, dv)

      implicit double precision (a-h, o-z)

      include 'sizes.h'

      include 'qsats.h'

      real*8, intent(out) :: vloc

      common /bincom/ bin, binvrs, r2min

      dimension q(NATOM3), dv(NATOM3)

! --- loop over all interacting pairs.
! --- potential for one configuration

      vloc = 0.0d0

      do n = 1, nvpair2

         i = ivpair2(1, n)
         j = ivpair2(2, n)

         dx = -((q(3*j-2))+vpvec2(1, n)+(-q(3*i-2)))
         dy = -((q(3*j-1))+vpvec2(2, n)+(-q(3*i-1)))
         dz = -((q(3*j))  +vpvec2(3, n)+(-q(3*i))  )

         r2 = dx*dx+dy*dy+dz*dz
         r = dsqrt(r2)

         ibin = int((r2-r2min)*binvrs)+1

         if (ibin.gt.0) then

            dr=(r2-r2min)-bin*dble(ibin-1)
            vloc=vloc+v(1, ibin)+v(2, ibin)*dr

         else

            vloc=vloc+v(1, 1)+(r2-r2min)*v(2,1)

         end if

      end do

! ----- classical force for each DoF (NATOM3)
      dv = 0d0

      do n=1, nvpair2

        i = ivpair2(1,n)
        j = ivpair2(2,n)

        dx=-((q(3*j-2))+vpvec2(1, n)+(-q(3*i-2)))
        dy=-((q(3*j-1))+vpvec2(2, n)+(-q(3*i-1)))
        dz=-((q(3*j))  +vpvec2(3, n)+(-q(3*i))  )

        r2=dx*dx+dy*dy+dz*dz
        r = dsqrt(r2)

        ibin=int((r2-r2min)*binvrs)+1

        if (ibin.gt.1) then
           dr = (r2-r2min)-bin*dble(ibin-1)
           z = v(2,ibin)+(v(2,ibin+1)-v(2,ibin-1))/2d0*dr*binvrs

           dv(3*i-2) = dv(3*i-2)+z*dx*2d0
           dv(3*i-1) = dv(3*i-1)+z*dy*2d0
           dv(3*i)   = dv(3*i)  +z*dz*2d0

           dv(3*j-2) = dv(3*j-2)-z*dx*2d0
           dv(3*j-1) = dv(3*j-1)-z*dy*2d0
           dv(3*j)   = dv(3*j)  -z*dz*2d0

        else
!           dr = (r2-r2min)-bin*dble(ibin-1)
           z = v(2,1)

!           z = 0d0
           dv(3*i-2) = dv(3*i-2)+z*dx*2d0
           dv(3*i-1) = dv(3*i-1)+z*dy*2d0
           dv(3*i)   = dv(3*i)  +z*dz*2d0

           dv(3*j-2) = dv(3*j-2)-z*dx*2d0
           dv(3*j-1) = dv(3*j-1)-z*dy*2d0
           dv(3*j)   = dv(3*j)  -z*dz*2d0
!           write(*,*) "Out of range of r2."
         end if

       enddo

      return
      end subroutine


      subroutine hext(smt,ev,mcov,delm,wroot,wegnv,windx)
      real*4 mcov(6,6)
      dimension smt(6),ev(3,3)
      dimension ah(6,1),temp(1,6),se(1,1),wvec(4)
      dimension ah1(6,1),ah2(6,1),ah2d(6,2),temp2(2,6),w(2,2)
      dimension wev(2,2),indx(3),wroot(2,3),windx(2,3)
      dimension wegnv(2,2,3),delm(3)
      equivalence (ah2d(1,1),ah1(1,1)),(ah2d(1,2),ah2(1,1))
      data indx/1,3,6/
c
c     computation of error on eigenvalue
c
      do 5 i=1,3
c
c     form ahat matrix, p.356 of hext
c
      call ahat(ev(1,i),ev(1,i),ah)
c
c     form ahat(transpose)* at*a inv
c
      call mult(ah,-1,mcov,1,temp,1,6,6,6,6,1,0)
c
c     form ahat(t) * a(t)*a inv * ahat
c
      call mult(temp,1,ah,1,se,1,6,1,1,6,1,0)
c
5     delm(i)=sqrt(se(1,1))
c
c     computation of error elipse on eigenvector
c
      do 10 i=1,3
      i1=i+1
      i2=i+2
      if(i1.gt.3) i1=i1-3
      if(i2.gt.3) i2=i2-3
c
c     calculate wihat using eq. 5.6 in hext(1963).
c     first compute ahats
c
      call ahat(ev(1,i1),ev(1,i),ah1)
      call ahat(ev(1,i2),ev(1,i),ah2)
c
c     scale the ahats
c
      in0=indx(i)
      in1=indx(i1)
      in2=indx(i2)
      scale1=1.0/(smt(in0)-smt(in1))
      scale2=1.0/(smt(in0)-smt(in2))
c
      do 15 j=1,6
      ah1(j,1)=scale1*ah1(j,1)
15    ah2(j,1)=scale2*ah2(j,1)
c
c     form ah2d(t) * a(t)*a inv
c
      call mult(ah2d,-1,mcov,1,temp2,2,6,6,6,6,2,0)
c
c     form ah2d(t) * a(t)*a inv * ah2d
c
      call mult(temp2,1,ah2d,1,w,2,6,2,2,6,2,0)
c
c     form matrix to be diagonalized
c
      wvec(1)=w(1,1)
      wvec(2)=w(1,2)
      wvec(3)=w(2,2)
c
      call eigens(wvec,wev,2,0)
c
      wroot(1,i)=wvec(1)
      wroot(2,i)=wvec(3)
      wegnv(1,1,i)=wev(1,1)
      wegnv(2,1,i)=wev(2,1)
      wegnv(1,2,i)=wev(1,2)
      wegnv(2,2,i)=wev(2,2)
c
      windx(1,i)=in1
      windx(2,i)=in2
c
10    continue
c
      return
      end


*     MB04PU/MB04WP EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO, ONE, TWO
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 100 )
      INTEGER          LDA, LDQG, LDRES, LDU1, LDU2, LDWORK
      PARAMETER        ( LDA  = NMAX, LDQG = NMAX, LDRES  = NMAX,
     $                   LDU1 = NMAX, LDU2 = NMAX, LDWORK = 2*NMAX )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, N
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA, NMAX), CS(2*NMAX), DWORK(LDWORK),
     $                 QG(LDQG, NMAX+1), RES(LDRES,3*NMAX+1), TAU(NMAX),
     $                 U1(LDU1,NMAX), U2(LDU2, NMAX)
*     .. External Functions ..
      DOUBLE PRECISION MA02ID, MA02JD
      EXTERNAL         MA02ID, MA02JD
*     .. External Subroutines ..
      EXTERNAL         DGEMM, DLACPY, DLASET, DSCAL, DSYMM, DSYR,
     $                 DSYR2K, DTRMM, MB04PU, MB04WP
*     .. Executable Statements ..
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * )  N
      IF( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         CALL DLACPY( 'All', N, N, A, LDA, RES(1,N+1), LDRES )
         READ ( NIN, FMT = * ) ( ( QG(I,J), J = 1,N+1 ), I = 1,N )
         CALL DLACPY( 'All', N, N+1, QG, LDQG, RES(1,2*N+1), LDRES )
         CALL MB04PU( N, 1, A, LDA, QG, LDQG, CS, TAU, DWORK, LDWORK,
     $                INFO )
         INFO = 0
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            CALL DLACPY( 'Lower', N, N, A, LDA, U1, LDU1 )
            CALL DLACPY( 'Lower', N, N, QG, LDQG, U2, LDU2 )
            CALL MB04WP( N, 1, U1, LDU1, U2, LDU2, CS, TAU, DWORK,
     $                   LDWORK, INFO )
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99997 ) INFO
            ELSE
               IF ( N.GT.2 )
     $            CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, A(3,1),
     $                         LDA )
               IF ( N.GT.1 )
     $            CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, QG(2,1),
     $                         LDQG )
               WRITE ( NOUT, FMT = 99996 )
               DO 10  I = 1, N
                  WRITE (NOUT, FMT = 99993)
     $                  ( U1(I,J), J = 1,N ), ( U2(I,J), J = 1,N )
10             CONTINUE
               DO 20  I = 1, N
                  WRITE (NOUT, FMT = 99993)
     $                  ( -U2(I,J), J = 1,N ), ( U1(I,J), J = 1,N )
20             CONTINUE
               WRITE ( NOUT, FMT = 99991 ) MA02JD( .FALSE., .FALSE., N,
     $                 U1, LDU1, U2, LDU2, RES, LDRES )
               WRITE ( NOUT, FMT = 99995 )
               DO 30  I = 1, N
                  WRITE (NOUT, FMT = 99993) ( A(I,J), J = 1,N )
30             CONTINUE
               WRITE ( NOUT, FMT = 99994 )
               DO 40  I = 1, N
                  WRITE (NOUT, FMT = 99993) ( QG(I,J), J = 1,N+1 )
40             CONTINUE
C
               CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE,
     $                     U1, LDU1, A, LDA, ZERO, RES, LDRES )
               CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, -ONE,
     $                     RES, LDRES, U1, LDU1, ONE, RES(1,N+1),
     $                     LDRES )
               CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE,
     $                     U2, LDU2, A, LDA, ZERO, RES, LDRES )
               CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE,
     $                     RES, LDRES, U2, LDU2, ONE, RES(1,N+1),
     $                     LDRES )
               CALL DSYMM ( 'Right', 'Upper', N, N, ONE, QG(1,2), LDQG,
     $                      U1, LDU1, ZERO, RES, LDRES )
               CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, -ONE,
     $                     RES, LDRES, U2, LDU2, ONE, RES(1,N+1),
     $                     LDRES )
               CALL DLACPY( 'All', N, N, U2, LDU2, RES, LDRES )
               DO 50 I = 1, N
                   CALL DSCAL( N, QG(I,I), RES(1,I), 1 )
50             CONTINUE
               CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, -ONE,
     $                     RES, LDRES, U1, LDU1, ONE, RES(1,N+1),
     $                     LDRES )
               CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE,
     $                     U2, LDU2, A, LDA, ZERO, RES, LDRES )
               CALL DSYR2K( 'Lower', 'No Transpose', N, N, ONE, RES,
     $                      LDRES, U1, LDU1, ONE, RES(1,2*N+1), LDRES )
               CALL DSCAL( N, ONE/TWO, QG(1,2), LDQG+1 )
               CALL DLACPY( 'Full', N, N, U2, LDU2, RES, LDRES )
               CALL DTRMM(  'Right', 'Upper' , 'No Transpose',
     $                      'Not unit', N, N, ONE, QG(1,2), LDQG,
     $                       RES, LDRES )
               CALL DSYR2K( 'Lower', 'No Transpose', N, N, ONE, RES,
     $                      LDRES, U2, LDU2, ONE, RES(1,2*N+1), LDRES )
               DO 60  I = 1, N
                  CALL DSYR( 'Lower', N, -QG(I,I), U1(1,I), 1,
     $                       RES(1,2*N+1), LDRES )
60             CONTINUE
               CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE,
     $                     U1, LDU1, A, LDA, ZERO, RES, LDRES )
               CALL DSYR2K( 'Upper', 'No Transpose', N, N, ONE, RES,
     $                      LDRES, U2, LDU2, ONE, RES(1,2*N+2), LDRES )
               CALL DLACPY( 'Full', N, N, U1, LDU1, RES, LDRES )
               CALL DTRMM(  'Right', 'Upper' , 'No Transpose',
     $                      'Not unit', N, N, ONE, QG(1,2), LDQG,
     $                       RES, LDRES )
               CALL DSYR2K( 'Upper', 'No Transpose', N, N, -ONE, RES,
     $                      LDRES, U1, LDU1, ONE, RES(1,2*N+2), LDRES )
               DO 70  I = 1, N
                  CALL DSYR( 'Upper', N, QG(I,I), U2(1,I), 1,
     $                       RES(1,2*N+2), LDRES )
70             CONTINUE
C
               WRITE ( NOUT, FMT = 99990 )  MA02ID( 'Hamiltonian',
     $                'Frobenius', N, RES(1,N+1), LDRES, RES(1,2*N+1),
     $                LDRES, DWORK )
            END IF
         END IF
      END IF
*
99999 FORMAT (' TMB04PU EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB04PU = ',I2)
99997 FORMAT (' INFO on exit from MB04WP = ',I2)
99996 FORMAT (' The symplectic orthogonal factor U is ')
99995 FORMAT (/' The reduced matrix A is ')
99994 FORMAT (/' The reduced matrix QG is ')
99993 FORMAT (20(1X,F9.4))
99992 FORMAT (/' N is out of range.',/' N = ',I5)
99991 FORMAT (/' Orthogonality of U: || U''*U - I ||_F = ',G7.2)
99990 FORMAT (/' Residual: || H - U*R*U'' ||_F = ',G7.2)
      END


! test_mod_ls65.f90
!
! gfortran -Wall -O -o test_mod_ls65.ex mod_least65.f90 test_mod_ls65.f90 -llapack -lblas
! time ./test_mod_ls65.ex < tsls65.dat > tsls65.out
! ifort -mkl -O -o test_mod_ls65.ex mod_least65.f90 test_mod_ls65.f90
!
!-----
MODULE least_var
!
  IMPLICIT NONE
  integer, parameter :: DP = kind(1.0D0)
!
  integer(4), parameter :: set_NSMAX=2048
  real(DP) :: Q(set_NSMAX)
!
END MODULE least_var
!
!-----
program ts_modls65
!
  use mod_least, only : NPR,NS,NP,NPFIT,IPFIT,PA,IPRSW,IDRSW,OBS,WSQRT,LEAST,least_alloc,least_dealloc
  use least_var, only : Q,set_NSMAX
!
  IMPLICIT NONE
  integer, parameter :: DP = kind(1.0D0)
!
  real(DP) :: EPSR,SUMS,SIGST
  integer(4) :: I,MAXX,ICON
!
  NPR=6
  IDRSW=1  ! NUMERICAL DERIVATIVE
!
  READ(*,*) NS,NP,NPFIT
  WRITE(*,'(a,3I5)')'  NS,NP,NPFIT=',NS,NP,NPFIT
  if(NS > set_NSMAX) then
    write(*,*)' invalid input'  ;  stop
  endif
  call least_alloc
  READ(*,*) (IPFIT(I),I=1,NPFIT)
  WRITE(*,'(a)')'  IPFIT'
  WRITE(*,'(5I3,2X,5I3)')(IPFIT(I),I=1,NPFIT)
  READ(*,*) (PA(I),I=1,NP)
  WRITE(*,'(a)')'  PA'
  WRITE(*,'(2G15.7)')(PA(I),I=1,2)
  WRITE(*,'(3G15.7)')(PA(I),I=3,NP)
  READ(*,*) EPSR,MAXX,IPRSW
  WRITE(*,'(a,g15.7,I10)')'  EPSR,MAXX=',EPSR,MAXX
  WRITE(*,'(a,I10)')'  IPRSW=',IPRSW
  WRITE(*,'(a)')'  IDRSW=1   NUMERICAL DERIVATIVE'
  do i=1,NS
    READ(*,*)Q(I),OBS(I),WSQRT(I)
  end do
!
  CALL LEAST(EPSR,MAXX,SUMS,SIGST,ICON)
  WRITE(*,'(''    LEAST ICON='',I7)')ICON
  call least_dealloc
!
end program ts_modls65
!
!-----
subroutine FMODL
!
  use mod_least, only : PA,CALC,NS
  use least_var, only : Q
!
  IMPLICIT NONE
  integer, parameter :: DP = kind(1.0D0)
  real(DP) :: xx
  integer(4) :: I,j
!
      DO I=1,NS
        xx=PA(1)+PA(2)*Q(I)
        do j=0,18
         xx=xx+PA(3+j*3)/( ( ( Q(I)-PA(4+j*3) )/PA(5+j*3) )**2 + 1.0d0 )
        end do
        CALC(I)=xx
      end do
!
end subroutine FMODL
!
!-----
subroutine DFMODL
  IMPLICIT NONE
!
  continue
  return
!
end subroutine DFMODL
!


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! ZUFFGR (Zouble Unitary hessenberg Factored Fuse Givens Rotation)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine fuses a Givens rotation represented by 3 real numbers:
! the real and imaginary parts of a complex cosine and a scrictly real
! sine into the top or bottom of a unitary hessenberg matrix that is
! stored as a product of givens rotations and a complex diagonal matrix.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  JOB             CHARACTER
!                    'T': fuses at the Top from the left
!                    'B': fuses at the Bottom from the right
!
!  N               INTEGER
!                    dimension of matrix
!
!  STR             INTEGER
!                    index of the top most givens rotation where
!                    fusion could happen
!
!  STP             INTEGER
!                    index of the bottom most givens rotation where
!                    fusion could happen
!
!  Q               REAL(8) array of dimension (3*(N-1))
!                    array of generators for givens rotations
!
!  D               REAL(8) array of dimension (2*N)
!                    array of generators for complex diagonal matrix
!
!  B               REAL(8) array of dimension (3)
!                    generators for rotation that will be fused
!
! OUTPUT VARIABLES:
!
!  INFO           INTEGER
!                   INFO = 0 implies successful computation
!                   INFO = -1 implies JOB is invalid
!                   INFO = -2 implies N is invalid
!                   INFO = -3 implies STR is invalid
!                   INFO = -4 implies STP is invalid
!                   INFO = -7 implies B is invalid
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine ZUFFGR(JOB,N,STR,STP,Q,D,B,INFO)

  implicit none

  ! input variables
  character, intent(in) :: JOB
  integer, intent(in) :: N, STR, STP
  integer, intent(inout) :: INFO
  real(8), intent(inout) :: Q(3*(N-1)),D(2*N)
  real(8), intent(in) :: B(3)

  ! compute variables
  integer :: k,ii
  real(8) :: c1r, c1i, s1
  real(8) :: c2r, c2i, s2
  real(8) :: c3r, c3i, s3r, s3i
  real(8) :: d1r, d1i
  real(8) :: d2r, d2i
  real(8) :: phr, phi
  real(8) :: nrm

  ! initialize INFO
  INFO = 0

  ! check input in debug mode
  if (DEBUG) then

    ! check JOB
    if ((JOB.NE.'T').AND.(JOB.NE.'B')) then
      INFO = -1
      call UARERR(__FILE__,__LINE__,"JOB must be 'T' or 'B'",INFO,INFO)
      return
    end if

    ! check N
    call IARNAN(N,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"N is invalid",INFO,-2)
      return
    end if
    call IARINF(N,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"N is invalid",INFO,-2)
      return
    end if
    if (N < 2) then
      INFO = -2
      call UARERR(__FILE__,__LINE__,"N must be at least 2",INFO,INFO)
      return
    end if

    ! check STR
    if ((STR < 1).OR.(STR > N-1)) then
      INFO = -3
      call UARERR(__FILE__,__LINE__,"STR must 1 <= STR <= N-1",INFO,INFO)
      return
    end if

    ! check STP
    if ((STP < STR).OR.(STP > N-1)) then
      INFO = -4
      call UARERR(__FILE__,__LINE__,"STP must STR <= STP <= N-1",INFO,INFO)
      return
    end if

    ! check B
    call DARACH1(3,B,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"B is invalid",INFO,-7)
      return
    end if

  end if

  ! fusion at bottom
  if(JOB.EQ.'B')then

    ! pass through diag
    call ZARGTD('R',D((2*(STP-1)+1):(2*(STP-1)+4)),B,INFO)

    ! check INFO in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"ZARGTD failed",INFO,INFO)
      if (INFO.NE.0) then
        return
      end if
    end if

    ! set inputs
    c2r = B(1)
    c2i = B(2)
    s2 = B(3)

    ! retrieve Q
    k = 3*(STP-1)
    c1r = Q(k+1)
    c1i = Q(k+2)
    s1 = Q(k+3)

    ! retrieve D
    k = 2*(STP-1)
    d1r = D(k+1)
    d1i = D(k+2)
    d2r = D(k+3)
    d2i = D(k+4)

    ! compute givens product
    c3r = c1r*c2r - c1i*c2i - s1*s2
    c3i = c1r*c2i + c1i*c2r
    s3r = s1*c2r + s2*c1r
    s3i = s1*c2i - s2*c1i

    ! compute phase
    nrm = abs(cmplx(s3r,s3i,kind=8))
    if(nrm /= 0)then
      phr = s3r/nrm
      phi = s3i/nrm
    else
      phr = 1d0
      phi = 0d0
    end if

    ! update Q
    c2r = c3r*phr + c3i*phi
    c2i = -c3r*phi + c3i*phr
    s2 = nrm
    nrm = sqrt(c2r*c2r + c2i*c2i + s2*s2)
    c2r = c2r/nrm
    c2i = c2i/nrm
    s2 = s2/nrm
    k = 3*(STP-1)
    Q(k+1) = c2r
    Q(k+2) = c2i
    Q(k+3) = s2

    ! update D
    c1r = phr*d1r - phi*d1i
    c1i = phr*d1i + phi*d1r
    nrm = sqrt(c1r*c1r + c1i*c1i)
    c1r = c1r/nrm
    c1i = c1i/nrm
    c2r = phr*d2r + phi*d2i
    c2i = phr*d2i - phi*d2r
    nrm = sqrt(c2r*c2r + c2i*c2i)
    c2r = c2r/nrm
    c2i = c2i/nrm
    k = 2*(STP-1)
    D(k+1) = c1r
    D(k+2) = c1i
    D(k+3) = c2r
    D(k+4) = c2i

  ! fusion at the top
  else

    ! set inputs
    c2r = B(1)
    c2i = B(2)
    s2 = B(3)

    ! retrieve Q
    k = 3*(STR-1)
    c1r = Q(k+1)
    c1i = Q(k+2)
    s1 = Q(k+3)

    ! retrieve D
    k = 2*(STR-1)
    d1r = D(k+1)
    d1i = D(k+2)
    k = 2*(STP)
    d2r = D(k+1)
    d2i = D(k+2)

    ! compute givens product
    c3r = c1r*c2r - c1i*c2i - s1*s2
    c3i = c1r*c2i + c1i*c2r
    s3r = s1*c2r + s2*c1r
    s3i = -(s1*c2i - s2*c1i)

    ! compute phase
    nrm = abs(cmplx(s3r,s3i,kind=8))
    if(nrm /= 0)then
       phr = s3r/nrm
       phi = s3i/nrm
    else
       phr = 1d0
       phi = 0d0
    end if

    ! update Q
    c2r = c3r*phr + c3i*phi
    c2i = -c3r*phi + c3i*phr
    s2 = nrm
    nrm = sqrt(c2r*c2r + c2i*c2i + s2*s2)
    c2r = c2r/nrm
    c2i = c2i/nrm
    s2 = s2/nrm
    k = 3*(STR-1)
    Q(k+1) = c2r
    Q(k+2) = c2i
    Q(k+3) = s2

    do ii=(STR+1),STP
      k = 3*(ii-1)
      c1r = Q(k+1)
      c1i = Q(k+2)
      s1 = Q(k+3)
      nrm = c1r*phr + c1i*phi
      c1i = -c1r*phi + c1i*phr
      c1r = nrm
      nrm = sqrt(c1r*c1r + c1i*c1i + s1*s1)
      c1r = c1r/nrm
      c1i = c1i/nrm
      s1 = s1/nrm
      Q(k+1) = c1r
      Q(k+2) = c1i
      Q(k+3) = s1
    end do

    ! update D
    c1r = phr*d1r - phi*d1i
    c1i = phr*d1i + phi*d1r
    nrm = sqrt(c1r*c1r + c1i*c1i)
    c1r = c1r/nrm
    c1i = c1i/nrm
    c2r = phr*d2r + phi*d2i
    c2i = phr*d2i - phi*d2r
    nrm = sqrt(c2r*c2r + c2i*c2i)
    c2r = c2r/nrm
    c2i = c2i/nrm

    k = 2*(STR-1)
    D(k+1) = c1r
    D(k+2) = c1i
    k = 2*(STP)
    D(k+1) = c2r
    D(k+2) = c2i

  end if

end subroutine ZUFFGR


! =============================================================================
!                       Test free slip boundary condition
!
!       This unit test checks the free slip boundary condition which is
!       implied in vertical direction. Ellipsoids are placed such that
!       the parcels at the bottom and at the top have two ellipsoid points
!       reaching out the physical domain. We use 4 parcels per cell. After
!       interpolating the parcel volume (volume = 0.125 * vcell per parcel),
!       the gridded volume is ngrid * vcell where ngrid is the number of
!       grid points.
! =============================================================================
program test_free_slip_3d
    use unit_test
    use constants, only : pi, zero                &
                        , one, two, three, five   &
                        , f12, f14, f18, f23, ten
    use parcel_container
    use parcel_ellipsoid, only : get_abc, get_B33
    use parcel_interpl, only : vol2grid
    use parameters, only : lower, extent, update_parameters, vcell, dx, nx, ny, nz, ngrid
    use fields, only : volg
    use timer
    implicit none

    integer :: i, j, k, l, kk, jj, ii
    double precision :: error, a2, b2, c2, abc, abc23

    nx = 2
    ny = 2
    nz = 2
    lower  = (/zero, zero, zero/)
    extent = (/one, one, one/)

    call update_parameters

    allocate(volg(-1:nz+1, 0:ny-1, 0:nx-1))

    call parcel_alloc(2 * 8 * nx * ny * nz)

    l = 1
    do k = 0, nz-1
        do j = 0, ny-1
            do i = 0, nx-1
                do kk = 1, 4, 2
                    do jj = 1, 4, 2
                        do ii = 1, 4, 2
                            parcels%position(1, l) = lower(1) + i * dx(1) + f14 * dx(1) * ii
                            parcels%position(2, l) = lower(2) + j * dx(2) + f14 * dx(2) * jj
                            parcels%position(3, l) = lower(3) + k * dx(3) + f14 * dx(3) * kk
                            l = l + 1
                        enddo
                    enddo
                enddo
            enddo
        enddo
    enddo
    n_parcels = l - 1

    volg = zero

    parcels%volume = f18 * vcell

    abc = get_abc(parcels%volume(1))
    abc23 = abc ** f23
    a2 = ten * abc23
    b2 = abc23 / dsqrt(two)
    c2 = abc23 / dsqrt(five)

    parcels%B(1, :) = c2
    parcels%B(2, :) = zero
    parcels%B(3, :) = zero
    parcels%B(4, :) = b2
    parcels%B(5, :) = zero

    call vol2grid

    error = abs(sum(volg(0:nz, 0:ny-1, 0:nx-1)) - ngrid * vcell)

    call print_result_dp('Test free slip', error)

    call parcel_dealloc
    deallocate(volg)

end program test_free_slip_3d


!
! wavy - A spectral ocean wave modeling and development framework
! Copyright (c) 2017, Wavebit Scientific LLC
! All rights reserved.
!
! Licensed under the BSD-3 clause license. See LICENSE for details.
!
program test_dhh

use mod_precision,only:rk => realkind
use mod_spectrum,only:spectrum_type
use mod_spectral_shapes,only:donelanHamiltonHui,jonswapPeakFrequency
use mod_nondimensional,only:nondimensionalFrequency
use mod_functional,only:arange

implicit none

type(spectrum_type) :: spec
real(kind=rk),dimension(:),allocatable :: wspd
real(kind=rk),dimension(:),allocatable :: fetch
real(kind=rk),parameter :: grav = 9.8_rk
integer :: m,n

write(*,*)
write(*,*)'Test omnidirectional spectrum with Donelan et al. (1985) shape;'
write(*,*)'Vary wind speed from 5 to 60 m/s with 5 m/s increments.'
write(*,*)'Vary fetch between 1, 10, and 100 km.'
write(*,*)'Peak frequency based on JONSWAP.'
write(*,*)

! Initialize spectrum
spec = spectrum_type(fmin=0.0313_rk,fmax=2._rk,df=1.1_rk,ndirs=1,depth=1e3_rk)

! Set array of wind speed and fetch values:
wspd = arange(5,60,5)
fetch = [1e3_rk,1e4_rk,1e5_rk]

do m = 1,size(fetch)

  write(*,*)
  write(*,fmt='(a,f5.1,a)')'fetch = ',fetch(m)/1e3_rk,' km'
  write(*,fmt='(a)')'   wspd      Hs      Tp       Tm1      Tm2      mss      m0(f)'&
                  //'    m1(f)    m2(f)'
  write(*,fmt='(a)')'----------------------------------------------------------'&
                  //'----------------------'
  do n = 1,size(wspd)

    ! Set the spectrum field to Donelan-Hamilton-Hui parametric shape
    call spec % setSpectrum(donelanHamiltonHui(spec % getFrequency(),&
      fpeak=jonswapPeakFrequency(wspd(n),fetch(m),grav),wspd=wspd(n),grav=grav))

    write(*,fmt='(9(f8.4,1x))')wspd(n),spec % significantWaveHeight(),&
      1./spec % peakFrequency(),spec % meanPeriod(),&
      spec % meanPeriodZeroCrossing(),spec % meanSquareSlope(),&
      spec % frequencyMoment(0),spec % frequencyMoment(1),&
      spec % frequencyMoment(2)

  enddo

enddo

endprogram test_dhh


c       this file contains the following user-callable routines:
c
c
c       routine idz_frm transforms a vector via a composition
c       of Rokhlin's random transform, random subselection, and an FFT.
c
c       routine idz_sfrm transforms a vector into a vector
c       of specified length via a composition
c       of Rokhlin's random transform, random subselection, and an FFT.
c
c       routine idz_frmi initializes routine idz_frm.
c
c       routine idz_sfrmi initializes routine idz_sfrm.
c
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c
c
        subroutine idz_frm(m,n,w,x,y)
c
c       transforms x into y via a composition
c       of Rokhlin's random transform, random subselection, and an FFT.
c       In contrast to routine idz_sfrm, the present routine works best
c       when the length of the transformed vector is the integer n
c       output by routine idz_frmi, or when the length
c       is not specified, but instead determined a posteriori
c       using the output of the present routine. The transformed vector
c       output by the present routine is randomly permuted.
c
c       input:
c       m -- length of x
c       n -- greatest integer expressible as a positive integer power
c            of 2 that is less than or equal to m, as obtained
c            from the routine idz_frmi; n is the length of y
c       w -- initialization array constructed by routine idz_frmi
c       x -- vector to be transformed
c
c       output:
c       y -- transform of x
c
c       reference:
c       Halko, Martinsson, Tropp, "Finding structure with randomness:
c            probabilistic algorithms for constructing approximate
c            matrix decompositions," SIAM Review, 53 (2): 217-288,
c            2011.
c
        implicit none
        integer m,iw,n,k
        complex*16 w(17*m+70),x(m),y(n)
c
c
c       Apply Rokhlin's random transformation to x, obtaining
c       w(16*m+71 : 17*m+70).
c
        iw = w(3+m+n)
        call idz_random_transf(x,w(16*m+70+1),w(iw))
c
c
c       Subselect from  w(16*m+71 : 17*m+70)  to obtain y.
c
        call idz_subselect(n,w(3),m,w(16*m+70+1),y)
c
c
c       Copy y into  w(16*m+71 : 16*m+n+70).
c
        do k = 1,n
          w(16*m+70+k) = y(k)
        enddo ! k
c
c
c       Fourier transform  w(16*m+71 : 16*m+n+70).
c
        call zfftf(n,w(16*m+70+1),w(4+m+n))
c
c
c       Permute  w(16*m+71 : 16*m+n+70)  to obtain y.
c
        call idz_permute(n,w(3+m),w(16*m+70+1),y)
c
c
        return
        end
c
c
c
c
        subroutine idz_sfrm(l,m,n,w,x,y)
c
c       transforms x into y via a composition
c       of Rokhlin's random transform, random subselection, and an FFT.
c       In contrast to routine idz_frm, the present routine works best
c       when the length l of the transformed vector is known a priori.
c
c       input:
c       l -- length of y; l must be less than or equal to n
c       m -- length of x
c       n -- greatest integer expressible as a positive integer power
c            of 2 that is less than or equal to m, as obtained
c            from the routine idz_frmi
c       w -- initialization array constructed by routine idz_sfrmi
c       x -- vector to be transformed
c
c       output:
c       y -- transform of x
c
c       _N.B._: l must be less than or equal to n.
c
c       reference:
c       Halko, Martinsson, Tropp, "Finding structure with randomness:
c            probabilistic algorithms for constructing approximate
c            matrix decompositions," SIAM Review, 53 (2): 217-288,
c            2011.
c
        implicit none
        integer m,iw,n,l
        complex*16 w(21*m+70),x(m),y(l)
c
c
c       Apply Rokhlin's random transformation to x, obtaining
c       w(19*m+71 : 20*m+70).
c
        iw = w(4+m+l)
        call idz_random_transf(x,w(19*m+70+1),w(iw))
c
c
c       Subselect from  w(19*m+71 : 20*m+70)  to obtain
c       w(20*m+71 : 20*m+n+70).
c
        call idz_subselect(n,w(4),m,w(19*m+70+1),w(20*m+70+1))
c
c
c       Fourier transform  w(20*m+71 : 20*m+n+70).
c
        call idz_sfft(l,w(4+m),n,w(5+m+l),w(20*m+70+1))
c
c
c       Copy the desired entries from  w(20*m+71 : 20*m+n+70)
c       to y.
c
        call idz_subselect(l,w(4+m),n,w(20*m+70+1),y)
c
c
        return
        end
c
c
c
c
        subroutine idz_permute(n,ind,x,y)
c
c       copy the entries of x into y, rearranged according
c       to the permutation specified by ind.
c
c       input:
c       n -- length of ind, x, and y
c       ind -- permutation of n objects
c       x -- vector to be permuted
c
c       output:
c       y -- permutation of x
c
        implicit none
        integer n,ind(n),k
        complex*16 x(n),y(n)
c
c
        do k = 1,n
          y(k) = x(ind(k))
        enddo ! k
c
c
        return
        end
c
c
c
c
        subroutine idz_subselect(n,ind,m,x,y)
c
c       copies into y the entries of x indicated by ind.
c
c       input:
c       n -- number of entries of x to copy into y
c       ind -- indices of the entries in x to copy into y
c       m -- length of x
c       x -- vector whose entries are to be copied
c
c       output:
c       y -- collection of entries of x specified by ind
c
        implicit none
        integer n,ind(n),m,k
        complex*16 x(m),y(n)
c
c
        do k = 1,n
          y(k) = x(ind(k))
        enddo ! k
c
c
        return
        end
c
c
c
c
        subroutine idz_frmi(m,n,w)
c
c       initializes data for the routine idz_frm.
c
c       input:
c       m -- length of the vector to be transformed
c
c       output:
c       n -- greatest integer expressible as a positive integer power
c            of 2 that is less than or equal to m
c       w -- initialization array to be used by routine idz_frm
c
c
c       glossary for the fully initialized w:
c
c       w(1) = m
c       w(2) = n
c       w(3:2+m) stores a permutation of m objects
c       w(3+m:2+m+n) stores a permutation of n objects
c       w(3+m+n) = address in w of the initialization array
c                  for idz_random_transf
c       w(4+m+n:int(w(3+m+n))-1) stores the initialization array
c                                for zfft
c       w(int(w(3+m+n)):16*m+70) stores the initialization array
c                                for idz_random_transf
c
c
c       _N.B._: n is an output of the present routine;
c               this routine changes n.
c
c
        implicit none
        integer m,n,l,nsteps,keep,lw,ia
        complex*16 w(17*m+70)
c
c
c       Find the greatest integer less than or equal to m
c       which is a power of two.
c
        call idz_poweroftwo(m,l,n)
c
c
c       Store m and n in w.
c
        w(1) = m
        w(2) = n
c
c
c       Store random permutations of m and n objects in w.
c
        call id_randperm(m,w(3))
        call id_randperm(n,w(3+m))
c
c
c       Store the address within w of the idz_random_transf_init
c       initialization data.
c
        ia = 4+m+n+2*n+15
        w(3+m+n) = ia
c
c
c       Store the initialization data for zfft in w.
c
        call zffti(n,w(4+m+n))
c
c
c       Store the initialization data for idz_random_transf_init in w.
c
        nsteps = 3
        call idz_random_transf_init(nsteps,m,w(ia),keep)
c
c
c       Calculate the total number of elements used in w.
c
        lw = 3+m+n+2*n+15 + 3*nsteps*m+2*m+m/4+50
c
        if(16*m+70 .lt. lw) then
          call prinf('lw = *',lw,1)
          call prinf('16m+70 = *',16*m+70,1)
          stop
        endif
c
c
        return
        end
c
c
c
c
        subroutine idz_sfrmi(l,m,n,w)
c
c       initializes data for the routine idz_sfrm.
c
c       input:
c       l -- length of the transformed (output) vector
c       m -- length of the vector to be transformed
c
c       output:
c       n -- greatest integer expressible as a positive integer power
c            of 2 that is less than or equal to m
c       w -- initialization array to be used by routine idz_sfrm
c
c
c       glossary for the fully initialized w:
c
c       w(1) = m
c       w(2) = n
c       w(3) is unused
c       w(4:3+m) stores a permutation of m objects
c       w(4+m:3+m+l) stores the indices of the l outputs which idz_sfft
c                    calculates
c       w(4+m+l) = address in w of the initialization array
c                  for idz_random_transf
c       w(5+m+l:int(w(4+m+l))-1) stores the initialization array
c                                for idz_sfft
c       w(int(w(4+m+l)):19*m+70) stores the initialization array
c                                for idz_random_transf
c
c
c       _N.B._: n is an output of the present routine;
c               this routine changes n.
c
c
        implicit none
        integer l,m,n,idummy,nsteps,keep,lw,ia
        complex*16 w(21*m+70)
c
c
c       Find the greatest integer less than or equal to m
c       which is a power of two.
c
        call idz_poweroftwo(m,idummy,n)
c
c
c       Store m and n in w.
c
        w(1) = m
        w(2) = n
        w(3) = 0
c
c
c       Store random permutations of m and n objects in w.
c
        call id_randperm(m,w(4))
        call id_randperm(n,w(4+m))
c
c
c       Store the address within w of the idz_random_transf_init
c       initialization data.
c
        ia = 5+m+l+2*l+15+3*n
        w(4+m+l) = ia
c
c
c       Store the initialization data for idz_sfft in w.
c
        call idz_sffti(l,w(4+m),n,w(5+m+l))
c
c
c       Store the initialization data for idz_random_transf_init in w.
c
        nsteps = 3
        call idz_random_transf_init(nsteps,m,w(ia),keep)
c
c
c       Calculate the total number of elements used in w.
c
        lw = 4+m+l+2*l+15+3*n + 3*nsteps*m+2*m+m/4+50
c
        if(19*m+70 .lt. lw) then
          call prinf('lw = *',lw,1)
          call prinf('19m+70 = *',19*m+70,1)
          stop
        endif
c
c
        return
        end
c
c
c
c
        subroutine idz_poweroftwo(m,l,n)
c
c       computes l = floor(log_2(m)) and n = 2**l.
c
c       input:
c       m -- integer whose log_2 is to be taken
c
c       output:
c       l -- floor(log_2(m))
c       n -- 2**l
c
        implicit none
        integer l,m,n
c
c
        l = 0
        n = 1
c
 1000   continue
          l = l+1
          n = n*2
        if(n .le. m) goto 1000
c
        l = l-1
        n = n/2
c
c
        return
        end


C------------------------------------------------------------------------
C
      SUBROUTINE COBYLA (CALCFC, N,M,X,RHOBEG,RHOEND,IPRINT,MAXFUN,
     & W,IACT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      EXTERNAL CALCFC
      DIMENSION X(*),W(*),IACT(*)
C
C     This subroutine minimizes an objective function F(X) subject to M
C     inequality constraints on X, where X is a vector of variables that has
C     N components. The algorithm employs linear approximations to the
C     objective and constraint functions, the approximations being formed by
C     linear interpolation at N+1 points in the space of the variables.
C     We regard these interpolation points as vertices of a simplex. The
C     parameter RHO controls the size of the simplex and it is reduced
C     automatically from RHOBEG to RHOEND. For each RHO the subroutine tries
C     to achieve a good vector of variables for the current size, and then
C     RHO is reduced until the value RHOEND is reached. Therefore RHOBEG and
C     RHOEND should be set to reasonable initial changes to and the required
C     accuracy in the variables respectively, but this accuracy should be
C     viewed as a subject for experimentation because it is not guaranteed.
C     The subroutine has an advantage over many of its competitors, however,
C     which is that it treats each constraint individually when calculating
C     a change to the variables, instead of lumping the constraints together
C     into a single penalty function. The name of the subroutine is derived
C     from the phrase Constrained Optimization BY Linear Approximations.
C
C     The user must set the values of N, M, RHOBEG and RHOEND, and must
C     provide an initial vector of variables in X. Further, the value of
C     IPRINT should be set to 0, 1, 2 or 3, which controls the amount of
C     printing during the calculation. Specifically, there is no output if
C     IPRINT=0 and there is output only at the end of the calculation if
C     IPRINT=1. Otherwise each new value of RHO and SIGMA is printed.
C     Further, the vector of variables and some function information are
C     given either when RHO is reduced or when each new value of F(X) is
C     computed in the cases IPRINT=2 or IPRINT=3 respectively. Here SIGMA
C     is a penalty parameter, it being assumed that a change to X is an
C     improvement if it reduces the merit function
C                F(X)+SIGMA*MAX(0.0,-C1(X),-C2(X),...,-CM(X)),
C     where C1,C2,...,CM denote the constraint functions that should become
C     nonnegative eventually, at least to the precision of RHOEND. In the
C     printed output the displayed term that is multiplied by SIGMA is
C     called MAXCV, which stands for 'MAXimum Constraint Violation'. The
C     argument MAXFUN is an integer variable that must be set by the user to a
C     limit on the number of calls of CALCFC, the purpose of this routine being
C     given below. The value of MAXFUN will be altered to the number of calls
C     of CALCFC that are made. The arguments W and IACT provide real and
C     integer arrays that are used as working space. Their lengths must be at
C     least N*(3*N+2*M+11)+4*M+6 and M+1 respectively.
C
C     In order to define the objective and constraint functions, we require
C     a subroutine that has the name and arguments
C                SUBROUTINE CALCFC (N,M,X,F,CON)
C                DIMENSION X(*),CON(*)  .
C     The values of N and M are fixed and have been defined already, while
C     X is now the current vector of variables. The subroutine should return
C     the objective and constraint functions at X in F and CON(1),CON(2),
C     ...,CON(M). Note that we are trying to adjust X so that F(X) is as
C     small as possible subject to the constraint functions being nonnegative.
C
C     Partition the working space array W to provide the storage that is needed
C     for the main calculation.
C
      MPP=M+2
      ICON=1
      ISIM=ICON+MPP
      ISIMI=ISIM+N*N+N
      IDATM=ISIMI+N*N
      IA=IDATM+N*MPP+MPP
      IVSIG=IA+M*N+N
      IVETA=IVSIG+N
      ISIGB=IVETA+N
      IDX=ISIGB+N
      IWORK=IDX+N
      CALL COBYLB (CALCFC,N,M,MPP,X,RHOBEG,RHOEND,IPRINT,MAXFUN,W(ICON),
     1  W(ISIM),W(ISIMI),W(IDATM),W(IA),W(IVSIG),W(IVETA),W(ISIGB),
     2  W(IDX),W(IWORK),IACT)
      RETURN
      END
C------------------------------------------------------------------------------
      SUBROUTINE COBYLB (CALCFC,N,M,MPP,X,RHOBEG,RHOEND,IPRINT,MAXFUN,
     1  CON,SIM,SIMI,DATMAT,A,VSIG,VETA,SIGBAR,DX,W,IACT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION X(*),CON(*),SIM(N,*),SIMI(N,*),DATMAT(MPP,*),
     1  A(N,*),VSIG(*),VETA(*),SIGBAR(*),DX(*),W(*),IACT(*)
      EXTERNAL CALCFC
C
C     Set the initial values of some parameters. The last column of SIM holds
C     the optimal vertex of the current simplex, and the preceding N columns
C     hold the displacements from the optimal vertex to the other vertices.
C     Further, SIMI holds the inverse of the matrix that is contained in the
C     first N columns of SIM.
C
      ITOTAL=N*(3*N+2*M+11)+4*M+6
      IPTEM=MIN0(N,5)
      IPTEMP=IPTEM+1
      NP=N+1
      MP=M+1
      ALPHA=0.25d0
      BETA=2.1d0
      GAMMA=0.5d0
      DELTA=1.1d0
      RHO=RHOBEG
      PARMU=0.0d0

C     Fix compiler warnings
      IFLAG=1
      PARSIG=0
      SUM=0
      PREREC=0
      PREREM=0
      CMIN=0
      CMAX=0

      IF (IPRINT .GE. 2) PRINT 10, RHO
   10 FORMAT (/3X,'The initial value of RHO is',1PE13.6,2X,
     1  'and PARMU is set to zero.')
      NFVALS=0
      TEMP=1.0d0/RHO
      DO 30 I=1,N
      SIM(I,NP)=X(I)
      DO 20 J=1,N
      SIM(I,J)=0.0d0
   20 SIMI(I,J)=0.0d0
      SIM(I,I)=RHO
   30 SIMI(I,I)=TEMP
      JDROP=NP
      IBRNCH=0
C
C     Make the next call of the user-supplied subroutine CALCFC. These
C     instructions are also used for calling CALCFC during the iterations of
C     the algorithm.
C
   40 IF (NFVALS .GE. MAXFUN .AND. NFVALS .GT. 0) THEN
         IF (IPRINT .GE. 1) PRINT 50
   50      FORMAT (/3X,'Return from subroutine COBYLA because the ',
     1        'MAXFUN limit has been reached.')
         GOTO 600
      END IF
      NFVALS=NFVALS+1
      IF (IPRINT .EQ. 3) THEN
         PRINT *, '  SIM = ', (SIM(J,NP),J=1,N)
         PRINT *, '  DX = ', (DX(I),I=1,N)
         PRINT *, '  BEFORE: ', N, M, (X(I),I=1,N), F, (CON(I),I=1,M)
      END IF
      CALL CALCFC (N,M,X,F,CON)
      IF (IPRINT .EQ. 3) THEN
         PRINT *, '  AFTER: ', N, M, (X(I),I=1,N), F, (CON(I),I=1,M)
      END IF
      RESMAX=0.0d0
      IF (M .GT. 0) THEN
          DO 60 K=1,M
   60     RESMAX=DMAX1(RESMAX,-CON(K))
      END IF
      IF (NFVALS .EQ. IPRINT-1 .OR. IPRINT .EQ. 3) THEN
          PRINT 70, NFVALS,F,RESMAX,(X(I),I=1,IPTEM)
   70     FORMAT (/3X,'NFVALS =',I5,3X,'F =',1PE13.6,4X,'MAXCV =',
     1      1PE13.6/3X,'X =',1PE13.6,1P4E15.6)
          IF (IPTEM .LT. N) PRINT 80, (X(I),I=IPTEMP,N)
   80     FORMAT (1PE19.6,1P4E15.6)
      END IF
      CON(MP)=F
      CON(MPP)=RESMAX
      IF (IBRNCH .EQ. 1) GOTO 440
C
C     Set the recently calculated function values in a column of DATMAT. This
C     array has a column for each vertex of the current simplex, the entries of
C     each column being the values of the constraint functions (if any)
C     followed by the objective function and the greatest constraint violation
C     at the vertex.
C
      DO 90 K=1,MPP
   90 DATMAT(K,JDROP)=CON(K)
      IF (NFVALS .GT. NP) GOTO 130
C
C     Exchange the new vertex of the initial simplex with the optimal vertex if
C     necessary. Then, if the initial simplex is not complete, pick its next
C     vertex and calculate the function values there.
C
      IF (JDROP .LE. N) THEN
          IF (DATMAT(MP,NP) .LE. F) THEN
              X(JDROP)=SIM(JDROP,NP)
          ELSE
              SIM(JDROP,NP)=X(JDROP)
              DO 100 K=1,MPP
              DATMAT(K,JDROP)=DATMAT(K,NP)
  100         DATMAT(K,NP)=CON(K)
              DO 120 K=1,JDROP
              SIM(JDROP,K)=-RHO
              TEMP=0.0
              DO 110 I=K,JDROP
  110         TEMP=TEMP-SIMI(I,K)
  120         SIMI(JDROP,K)=TEMP
          END IF
      END IF
      IF (NFVALS .LE. N) THEN
          JDROP=NFVALS
          X(JDROP)=X(JDROP)+RHO
          GOTO 40
      END IF
  130 IBRNCH=1
C
C     Identify the optimal vertex of the current simplex.
C
  140 PHIMIN=DATMAT(MP,NP)+PARMU*DATMAT(MPP,NP)
      NBEST=NP
      DO 150 J=1,N
      TEMP=DATMAT(MP,J)+PARMU*DATMAT(MPP,J)
      IF (TEMP .LT. PHIMIN) THEN
          NBEST=J
          PHIMIN=TEMP
      ELSE IF (TEMP .EQ. PHIMIN .AND. PARMU .EQ. 0.0d0) THEN
          IF (DATMAT(MPP,J) .LT. DATMAT(MPP,NBEST)) NBEST=J
      END IF
  150 CONTINUE
C
C     Switch the best vertex into pole position if it is not there already,
C     and also update SIM, SIMI and DATMAT.
C
      IF (NBEST .LE. N) THEN
          DO 160 I=1,MPP
          TEMP=DATMAT(I,NP)
          DATMAT(I,NP)=DATMAT(I,NBEST)
  160     DATMAT(I,NBEST)=TEMP
          DO 180 I=1,N
          TEMP=SIM(I,NBEST)
          SIM(I,NBEST)=0.0d0
          SIM(I,NP)=SIM(I,NP)+TEMP
          TEMPA=0.0d0
          DO 170 K=1,N
          SIM(I,K)=SIM(I,K)-TEMP
  170     TEMPA=TEMPA-SIMI(K,I)
  180     SIMI(NBEST,I)=TEMPA
      END IF
C
C     Make an error return if SIGI is a poor approximation to the inverse of
C     the leading N by N submatrix of SIG.
C
      ERROR=0.0d0
      DO 200 I=1,N
      DO 200 J=1,N
      TEMP=0.0d0
      IF (I .EQ. J) TEMP=TEMP-1.0d0
      DO 190 K=1,N
  190 TEMP=TEMP+SIMI(I,K)*SIM(K,J)
  200 ERROR=DMAX1(ERROR,ABS(TEMP))
      IF (ERROR .GT. 0.1d0) THEN
          IF (IPRINT .GE. 1) PRINT 210
  210     FORMAT (/3X,'Return from subroutine COBYLA because ',
     1      'rounding errors are becoming damaging.')
          GOTO 600
      END IF
C
C     Calculate the coefficients of the linear approximations to the objective
C     and constraint functions, placing minus the objective function gradient
C     after the constraint gradients in the array A. The vector W is used for
C     working space.
C
      DO 240 K=1,MP
      CON(K)=-DATMAT(K,NP)
      DO 220 J=1,N
  220 W(J)=DATMAT(K,J)+CON(K)
      DO 240 I=1,N
      TEMP=0.0d0
      DO 230 J=1,N
  230 TEMP=TEMP+W(J)*SIMI(J,I)
      IF (K .EQ. MP) TEMP=-TEMP
  240 A(I,K)=TEMP
C
C     Calculate the values of sigma and eta, and set IFLAG=0 if the current
C     simplex is not acceptable.
C
      IFLAG=1
      PARSIG=ALPHA*RHO
      PARETA=BETA*RHO
      DO 260 J=1,N
      WSIG=0.0d0
      WETA=0.0d0
      DO 250 I=1,N
      WSIG=WSIG+SIMI(J,I)**2
  250 WETA=WETA+SIM(I,J)**2
      VSIG(J)=1.0d0/SQRT(WSIG)
      VETA(J)=SQRT(WETA)
      IF (VSIG(J) .LT. PARSIG .OR. VETA(J) .GT. PARETA) IFLAG=0
  260 CONTINUE
      IF (IPRINT .EQ. 3) THEN
         print *, '  SIMI = ', ((SIMI(I,J),I=1,N),J=1,N)
         print *, '   SIM = ', ((SIM(I,J),I=1,N),J=1,N)
         PRINT *, '  VSIG = ', (VSIG(J),J=1,N), ' -- ', PARSIG
         PRINT *, '  VETA = ', (VETA(J),J=1,N), ' -- ', PARETA
         PRINT *, '  IBRNCH, IFLAG = ', IBRNCH, IFLAG
         PRINT *, '  A = ', ((A(I,J),I=1,N),J=1,MP)
      END IF
C
C     If a new vertex is needed to improve acceptability, then decide which
C     vertex to drop from the simplex.
C
      IF (IBRNCH .EQ. 1 .OR. IFLAG .EQ. 1) GOTO 370
      JDROP=0
      TEMP=PARETA
      DO 270 J=1,N
      IF (VETA(J) .GT. TEMP) THEN
          JDROP=J
          TEMP=VETA(J)
      END IF
  270 CONTINUE
      IF (JDROP .EQ. 0) THEN
          DO 280 J=1,N
          IF (VSIG(J) .LT. TEMP) THEN
              JDROP=J
              TEMP=VSIG(J)
          END IF
  280     CONTINUE
      END IF
C
C     Calculate the step to the new vertex and its sign.
C
      TEMP=GAMMA*RHO*VSIG(JDROP)
      IF (IPRINT .EQ. 3) THEN
         PRINT *, '  SIMI =', (SIMI(JDROP,I),I=1,N)
      END IF
      DO 290 I=1,N
  290 DX(I)=TEMP*SIMI(JDROP,I)
      IF (IPRINT .EQ. 3) THEN
         PRINT *, '  DX =', (DX(I),I=1,N)
      END IF
      CVMAXP=0.0d0
      CVMAXM=0.0d0
      DO 310 K=1,MP
      SUM=0.0d0
      DO 300 I=1,N
  300 SUM=SUM+A(I,K)*DX(I)
      IF (K .LT. MP) THEN
          TEMP=DATMAT(K,NP)
          CVMAXP=DMAX1(CVMAXP,-SUM-TEMP)
          CVMAXM=DMAX1(CVMAXM,SUM-TEMP)
      END IF
  310 CONTINUE
      DXSIGN=1.0d0
      IF (PARMU*(CVMAXP-CVMAXM) .GT. SUM+SUM) DXSIGN=-1.0d0
C
C     Update the elements of SIM and SIMI, and set the next X.
C
      TEMP=0.0d0
      DO 320 I=1,N
      DX(I)=DXSIGN*DX(I)
      SIM(I,JDROP)=DX(I)
  320 TEMP=TEMP+SIMI(JDROP,I)*DX(I)
      DO 330 I=1,N
  330 SIMI(JDROP,I)=SIMI(JDROP,I)/TEMP
      DO 360 J=1,N
      IF (J .NE. JDROP) THEN
          TEMP=0.0d0
          DO 340 I=1,N
  340     TEMP=TEMP+SIMI(J,I)*DX(I)
          DO 350 I=1,N
  350     SIMI(J,I)=SIMI(J,I)-TEMP*SIMI(JDROP,I)
      END IF
  360 X(J)=SIM(J,NP)+DX(J)
      GOTO 40
C
C     Calculate DX=x(*)-x(0). Branch if the length of DX is less than 0.5*RHO.
C
  370 IZ=1
      IZDOTA=IZ+N*N
      IVMC=IZDOTA+N
      ISDIRN=IVMC+MP
      IDXNEW=ISDIRN+N
      IVMD=IDXNEW+N
      CALL TRSTLP (N,M,A,CON,RHO,DX,IFULL,IACT,W(IZ),W(IZDOTA),
     1  W(IVMC),W(ISDIRN),W(IDXNEW),W(IVMD),IPRINT)
      IF (IFULL .EQ. 0) THEN
          TEMP=0.0d0
          DO 380 I=1,N
  380     TEMP=TEMP+DX(I)**2
          IF (TEMP .LT. 0.25d0*RHO*RHO) THEN
              IBRNCH=1
              GOTO 550
          END IF
      END IF
C
C     Predict the change to F and the new maximum constraint violation if the
C     variables are altered from x(0) to x(0)+DX.
C
      RESNEW=0.0d0
      CON(MP)=0.0d0
      DO 400 K=1,MP
      SUM=CON(K)
      DO 390 I=1,N
  390 SUM=SUM-A(I,K)*DX(I)
      IF (K .LT. MP) RESNEW=DMAX1(RESNEW,SUM)
  400 CONTINUE
C
C     Increase PARMU if necessary and branch back if this change alters the
C     optimal vertex. Otherwise PREREM and PREREC will be set to the predicted
C     reductions in the merit function and the maximum constraint violation
C     respectively.
C
      BARMU=0.0d0
      PREREC=DATMAT(MPP,NP)-RESNEW
      IF (PREREC .GT. 0.0d0) BARMU=SUM/PREREC
      IF (PARMU .LT. 1.5d0*BARMU) THEN
          PARMU=2.0d0*BARMU
          IF (IPRINT .GE. 2) PRINT 410, PARMU
  410     FORMAT (/3X,'Increase in PARMU to',1PE13.6)
          PHI=DATMAT(MP,NP)+PARMU*DATMAT(MPP,NP)
          DO 420 J=1,N
          TEMP=DATMAT(MP,J)+PARMU*DATMAT(MPP,J)
          IF (TEMP .LT. PHI) GOTO 140
          IF (TEMP .EQ. PHI .AND. PARMU .EQ. 0.0) THEN
              IF (DATMAT(MPP,J) .LT. DATMAT(MPP,NP)) GOTO 140
          END IF
  420     CONTINUE
      END IF
      PREREM=PARMU*PREREC-SUM
C
C     Calculate the constraint and objective functions at x(*). Then find the
C     actual reduction in the merit function.
C
      DO 430 I=1,N
  430 X(I)=SIM(I,NP)+DX(I)
      IBRNCH=1
      GOTO 40
  440 VMOLD=DATMAT(MP,NP)+PARMU*DATMAT(MPP,NP)
      VMNEW=F+PARMU*RESMAX
      TRURED=VMOLD-VMNEW
      IF (PARMU .EQ. 0.0d0 .AND. F .EQ. DATMAT(MP,NP)) THEN
          PREREM=PREREC
          TRURED=DATMAT(MPP,NP)-RESMAX
      END IF
C
C     Begin the operations that decide whether x(*) should replace one of the
C     vertices of the current simplex, the change being mandatory if TRURED is
C     positive. Firstly, JDROP is set to the index of the vertex that is to be
C     replaced.
C
      RATIO=0.0d0
      IF (TRURED .LE. 0.0) RATIO=1.0
      JDROP=0
      DO 460 J=1,N
      TEMP=0.0d0
      DO 450 I=1,N
  450 TEMP=TEMP+SIMI(J,I)*DX(I)
      TEMP=ABS(TEMP)
      IF (TEMP .GT. RATIO) THEN
          JDROP=J
          RATIO=TEMP
      END IF
  460 SIGBAR(J)=TEMP*VSIG(J)
C
C     Calculate the value of ell.
C
      EDGMAX=DELTA*RHO
      L=0
      DO 480 J=1,N
      IF (SIGBAR(J) .GE. PARSIG .OR. SIGBAR(J) .GE. VSIG(J)) THEN
          TEMP=VETA(J)
          IF (TRURED .GT. 0.0d0) THEN
              TEMP=0.0d0
              DO 470 I=1,N
  470         TEMP=TEMP+(DX(I)-SIM(I,J))**2
              TEMP=SQRT(TEMP)
          END IF
          IF (TEMP .GT. EDGMAX) THEN
              L=J
              EDGMAX=TEMP
          END IF
      END IF
  480 CONTINUE
      IF (L .GT. 0) JDROP=L
      IF (JDROP .EQ. 0) GOTO 550
C
C     Revise the simplex by updating the elements of SIM, SIMI and DATMAT.
C
      TEMP=0.0d0
      DO 490 I=1,N
      SIM(I,JDROP)=DX(I)
  490 TEMP=TEMP+SIMI(JDROP,I)*DX(I)
      DO 500 I=1,N
  500 SIMI(JDROP,I)=SIMI(JDROP,I)/TEMP
      DO 530 J=1,N
      IF (J .NE. JDROP) THEN
          TEMP=0.0d0
          DO 510 I=1,N
  510     TEMP=TEMP+SIMI(J,I)*DX(I)
          DO 520 I=1,N
  520     SIMI(J,I)=SIMI(J,I)-TEMP*SIMI(JDROP,I)
      END IF
  530 CONTINUE
      DO 540 K=1,MPP
  540 DATMAT(K,JDROP)=CON(K)
C
C     Branch back for further iterations with the current RHO.
C
      IF (TRURED .GT. 0.0d0 .AND. TRURED .GE. 0.1d0*PREREM) GOTO 140
  550 IF (IFLAG .EQ. 0) THEN
          IBRNCH=0
          GOTO 140
      END IF
C
C     Otherwise reduce RHO if it is not at its least value and reset PARMU.
C
      IF (RHO .GT. RHOEND) THEN
          RHO=0.5d0*RHO
          IF (RHO .LE. 1.5d0*RHOEND) RHO=RHOEND
          IF (PARMU .GT. 0.0d0) THEN
              DENOM=0.0d0
              DO 570 K=1,MP
              CMIN=DATMAT(K,NP)
              CMAX=CMIN
              DO 560 I=1,N
              CMIN=DMIN1(CMIN,DATMAT(K,I))
  560         CMAX=DMAX1(CMAX,DATMAT(K,I))
              IF (K .LE. M .AND. CMIN .LT. 0.5d0*CMAX) THEN
                  TEMP=DMAX1(CMAX,0.0d0)-CMIN
                  IF (DENOM .LE. 0.0d0) THEN
                      DENOM=TEMP
                  ELSE
                      DENOM=DMIN1(DENOM,TEMP)
                  END IF
              END IF
  570         CONTINUE
              IF (DENOM .EQ. 0.0d0) THEN
                  PARMU=0.0d0
              ELSE IF (CMAX-CMIN .LT. PARMU*DENOM) THEN
                  PARMU=(CMAX-CMIN)/DENOM
              END IF
          END IF
          IF (IPRINT .GE. 2) PRINT 580, RHO,PARMU
  580     FORMAT (/3X,'Reduction in RHO to',1PE13.6,'  and PARMU =',
     1      1PE13.6)
          IF (IPRINT .EQ. 2) THEN
              PRINT 70, NFVALS,DATMAT(MP,NP),DATMAT(MPP,NP),
     1          (SIM(I,NP),I=1,IPTEM)
              IF (IPTEM .LT. N) PRINT 80, (X(I),I=IPTEMP,N)
          END IF
          GOTO 140
      END IF
C
C     Return the best calculated values of the variables.
C
      IF (IPRINT .GE. 1) PRINT 590
  590 FORMAT (/3X,'Normal return from subroutine COBYLA')
      IF (IFULL .EQ. 1) GOTO 620
  600 DO 610 I=1,N
  610 X(I)=SIM(I,NP)
      F=DATMAT(MP,NP)
      RESMAX=DATMAT(MPP,NP)
  620 IF (IPRINT .GE. 1) THEN
          PRINT 70, NFVALS,F,RESMAX,(X(I),I=1,IPTEM)
          IF (IPTEM .LT. N) PRINT 80, (X(I),I=IPTEMP,N)
      END IF
      MAXFUN=NFVALS
      RETURN
      END


C NCLFORTSTART
      SUBROUTINE DSTDATMZ(NZ,Z,TT,DD,PP)
      IMPLICIT NONE
c                                   INPUT
      INTEGER NZ
      DOUBLE PRECISION Z(NZ)
c                                   OUTPUT
      DOUBLE PRECISION TT(NZ), DD(NZ), PP(NZ)
C NCLEND

C NCL:  tdp = stdAtmUsa76_z2tdp (z)

      INTEGER N,LFLAG

c multiple level interface for DSS "STDZ2P"
C  .  computes pressure, temperature, and density from input heights
C  .  based on US STANDARD ATMOSPHERE, 1976
C  .  values not valid above 84852 m.
C  Original source: NCAR, Data Support Section
C  .  http://dss.ucar.edu/libraries/meteorology/

c input only in meters from NCL
      LFLAG = 0

      DO N = 1,NZ
          IF (Z(N).GE.0.D0 .AND. Z(N).LE.84852.D0) THEN
              CALL STDZ2P(PP(N),Z(N),LFLAG,TT(N),DD(N))
          ELSE
              TT(N) = -999.D0
              DD(N) = -999.D0
              PP(N) = -999.D0
          END IF
      END DO

      RETURN
      END

C NCLFORTSTART
      SUBROUTINE DSTDATMP(NP,P,TT,DD,ZZ)
      IMPLICIT NONE
c                                   INPUT
      INTEGER NP
      DOUBLE PRECISION P(NP)
c                                   OUTPUT
      DOUBLE PRECISION TT(NP), DD(NP), ZZ(NP)
C NCLEND

C NCL:  tdz = stdAtmUsa76_p2tdz (p)

      INTEGER N
      DOUBLE PRECISION ZFT

c multiple level interface for DSS "STDP2Z"
C .   computes height, temperature, and density from input pressures
C .   based on US STANDARD ATMOSPHERE, 1976
C .   values not valid above 84852 m.
c .   do not return 'zft'
C  Original source: NCAR, Data Support Section
C  .  http://dss.ucar.edu/libraries/meteorology/

      DO N = 1,NP
          IF (P(N).GE.0.00373D0 .AND. P(N).LE.1013.25D0) THEN
              CALL STDP2Z(P(N),ZZ(N),ZFT,TT(N),DD(N))
          ELSE
              TT(N) = -999.D0
              DD(N) = -999.D0
              ZZ(N) = -999.D0
          END IF
      END DO

      RETURN
      END
C --------------------------------------------------
      SUBROUTINE STDZ2P(P,H1,L,TCENT,RHO)
      IMPLICIT NONE
      INTEGER L
      DOUBLE PRECISION P,H1,TCENT,RHO
C
C COMPUTES PRESSURE, TEMPERATURE, AND DENSITY VALUES FROM INPUT HEIGHTS
C  BASED ON US STANDARD ATMOSPHERE, 1976
C  VALUES NOT VALID ABOVE 84852 KM.
C
C INPUT
C       H1    - HEIGHT IN FEET OR METERS
C       L     - UNITS FLAG - 0=METERS, 1=FEET
C OUTPUT
C       P     - PRESSURE IN MB
C       TCENT - TEMPERATURE IN DEG C
C       RHO   - DENSITY IN KG/M3
C
      INTEGER I
      DOUBLE PRECISION HBASE(10),HTOP(10),TB(10),GRAD(10),ABST(10)
      DOUBLE PRECISION PB(11),RB(10),ABSZ,PZERP,G,R,CHECK,T,H,PZERO

      DATA HBASE/0.D0,1.1D4,2.D4,3.2D4,4.7D4,5.1D4,7.1D4,3*84852.0D0/
      DATA HTOP/1.1D4,2.D4,3.2D4,4.7D4,5.1D4,7.1D4,4*84852.0D0/
      DATA TB/15.D0,2*-56.5D0,-44.5D0,2*-2.5D0,-58.5D0,3*-86.2D0/
      DATA GRAD/-.0065D0,0.D0,0.001D0,0.0028D0,0.D0,-.0028D0,-.002D0,
     +     3*0.D0/
c djs DATA CHECK/0.D0/
C
C     H1 IS ALTITUDE: IF IN METERS SET L<=0.  IF IN FEET SET L>=1
C
c djs IF (CHECK.EQ.0.D0) THEN
          ABSZ  = 273.15D0
          PZERO = 1013.250D0
          G     = 980.665D0
          R     = 83143200.D0/28.9644D0
          PB(1) = PZERO

          DO I = 1,8
              ABST(I) = TB(I) + ABSZ
          END DO

          DO I = 1,8
              IF (GRAD(I).NE.0) THEN
                  PB(I+1) = PB(I)* (ABST(I+1)/ABST(I))**
     +                      (100.D0*G/ (-GRAD(I)*R))
              ELSE
                  PB(I+1) = PB(I)*2.7182818D0**
     +                      ((-100.D0*G/ (R*ABST(I)))*
     +                      (HTOP(I)-HBASE(I)))
              END IF
              RB(I) = 1000.D0*PB(I)/ (R*ABST(I))*1000.D0
          END DO
          CHECK = 10.D0
c djs END IF

      IF (L.GE.1) THEN
          H = H1*0.3048D0
      ELSE
          H = H1
      END IF

      DO I = 1,8
          IF (H.LE.HBASE(I+1)) THEN
              IF (GRAD(I).NE.0.D0) THEN
                  P = PB(I)* ((H-HBASE(I))*GRAD(I)/ABST(I)+1)**
     +                (-100.D0*G/ (GRAD(I)*R))
              ELSE
C                                 ISOTHERMAL LAYER
                  P = PB(I)*EXP((H-HBASE(I))* (-G)/ (0.01D0*R*ABST(I)))
              END IF

              T     = ABST(I) + GRAD(I)* (H-HBASE(I))
              TCENT = T - ABSZ
              RHO   = 1.D6*P/ (R*T)
              RETURN
          END IF
      END DO

      RETURN
      END
C --------------------------------------------------
      SUBROUTINE STDP2Z(P,H,HFT,TCENT,DENS)
      IMPLICIT NONE
      DOUBLE PRECISION P,H,HFT,TCENT,DENS
C
C COMPUTES HEIGHT, TEMPERATURE, AND DENSITY VALUES FROM INPUT PRESSURES
C  BASED ON US STANDARD ATMOSPHERE, 1976
C  VALUES NOT VALID ABOVE 84852 KM.
C
C INPUT
C       P     - PRESSURE IN MB
C OUTPUT
C       H     - HEIGHT IN METERS
C       HFT   - HEIGHT IN FEET
C       TCENT - TEMPERATURE IN DEG C
C       DENS  - DENSITY IN KG/M3
C
      INTEGER I
      DOUBLE PRECISION HBASE(10),HTOP(10),TB(10),GRAD(10),ABST(10),
     +                 PB(10),RB(10),ABSZ,G,R,T
      DATA HBASE/0.D0,1.1D4,2.D4,3.2D4,4.7D4,5.1D4,7.1D4,3*84852.0D0/
      DATA HTOP/1.1D4,2.D4,3.2D4,4.7D4,5.1D4,7.1D4,4*84852.0D0/
      DATA GRAD/-.0065D0,0.D0,0.001D0,0.0028D0,0.D0,-.0028D0,-.002D0,
     +     3*0.D0/
      DATA ABST/288.15D0,216.65D0,216.65D0,228.65D0,270.65D0,270.65D0,
     +     214.65D0,186.95D0,2*0.D0/
      DATA PB/1013.25D0,0.22632064D+03,0.54748887D+02,0.86801870D+01,
     +     0.11090631D+01,0.66938874D+00,0.39564205D-01,0.37338360D-02,
     +     2*0.D0/

      ABSZ = 273.15D0
      G = 980.665D0
      R = 83143200.D0/28.9644D0
      IF (P.LE.PB(1)) THEN
          DO I = 1,8
              IF (P.GE.PB(I+1)) GO TO 37
          END DO
      END IF

   37 CONTINUE
      IF (GRAD(I).NE.0.D0) THEN
          H = ABST(I)/ (-GRAD(I))* (1.D0-
     +        (P/PB(I))** (-GRAD(I)*R/ (100.D0*G))) + HBASE(I)
      ELSE
C  ISOTHERMAL LAYER
          H = HBASE(I) + 0.01D0*R*ABST(I)/G*DLOG(PB(I)/P)
      END IF

      T = ABST(I) + GRAD(I)* (H-HBASE(I))
      TCENT = T - ABSZ
      DENS = 1000*1000.D0*P/ (R*T)
      HFT = H/0.3048D0

      RETURN
      END


! =====================================================
subroutine rpn2(ixy,maxm,meqn,mwaves,maux,mbc,mx,ql,qr,auxl,auxr,wave,s,amdq,apdq)
! =====================================================
! Riemann-solver for the advection equation
!    q_t  +  u*q_x + v*q_y = 0
! where u and v are a given velocity field.

! waves: 1
! equations: 1
! aux fields: 2

! Conserved quantities:
!       1 q

! Auxiliary variables:
!         1  x_velocity
!         2  y_velocity

! solve Riemann problems along one slice of data.
! This data is along a slice in the x-direction if ixy=1
!                            or the y-direction if ixy=2.

! On input, ql contains the state vector at the left edge of each cell
!           qr contains the state vector at the right edge of each cell

! On output, wave contains the waves, s the speeds,
! and amdq, apdq the left-going and right-going flux differences,
! respectively.  Note that in this advective form, the sum of
! amdq and apdq is not equal to a difference of fluxes except in the
! case of constant velocities.

! Note that the i'th Riemann problem has left state qr(i-1,:)
!                                    and right state ql(i,:)
! From the basic clawpack routines, this routine is called with ql = qr

    implicit real*8(a-h,o-z)

    dimension wave(meqn, mwaves, 1-mbc:maxm+mbc)
    dimension    s(mwaves, 1-mbc:maxm+mbc)
    dimension   ql(meqn, 1-mbc:maxm+mbc)
    dimension   qr(meqn, 1-mbc:maxm+mbc)
    dimension apdq(meqn,1-mbc:maxm+mbc)
    dimension amdq(meqn,1-mbc:maxm+mbc)
    dimension auxl(maux,1-mbc:maxm+mbc)
    dimension auxr(maux,1-mbc:maxm+mbc)

!     # Set wave, speed, and flux differences:
!     ------------------------------------------

    do 30 i = 2-mbc, mx+mbc
        wave(1,1,i) = ql(1,i) - qr(1,i-1)
        s(1,i) = auxl(ixy,i)
    !        # The flux difference df = s*wave  all goes in the downwind direction:
        amdq(1,i) = dmin1(auxl(ixy,i), 0.d0) * wave(1,1,i)
        apdq(1,i) = dmax1(auxl(ixy,i), 0.d0) * wave(1,1,i)
    30 END DO

    return
    end subroutine rpn2