!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2015 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine objective_stress(nodeset,istartset,iendset,ialset,
     &  nk,idesvarc,iobject,mi,g0,nobject,stn,objectset)
!
!     calculates the sum of the square of the von Mises stress of a node
!     set
!
      implicit none
!
      character*81 objectset(3,*)
!
      integer nk,istartset(*),iendset(*),ialset(*),nodeset,idir,
     &  idesvarc,iobject,mi(*),j,k,nobject,idesvar
!
      real*8 g0(nobject),stn(6,*),p,rho,xstress
!
      idesvar=idesvarc+1
!
!     reading rho and the mean stress for the Kreisselmeier-Steinhauser
!     function
!
      read(objectset(2,iobject)(41:60),'(f20.0)') rho
      read(objectset(2,iobject)(61:80),'(f20.0)') xstress
!
      g0(iobject)=0.d0
!
!     check for the existence of a set, else take the complete mesh
!
      if(nodeset.eq.0) then
         do j=1,nk
            p=-(stn(1,j)+stn(2,j)+stn(3,j))/3.d0
            g0(iobject)=g0(iobject)+dexp(rho*dsqrt(1.5d0*
     &        ((stn(1,j)+p)**2+(stn(2,j)+p)**2+(stn(3,j)+p)**2+
     &         2.d0*(stn(4,j)**2+stn(5,j)**2+stn(6,j)**2)))/xstress)
         enddo
         g0(iobject)=dlog(g0(iobject))/rho
      else
         do j=istartset(nodeset),iendset(nodeset)
            if(ialset(j).gt.0) then
               k=ialset(j)
               p=-(stn(1,k)+stn(2,k)+stn(3,k))/3.d0
               g0(iobject)=g0(iobject)+dexp(rho*dsqrt(1.5d0*
     &        ((stn(1,k)+p)**2+
     &         (stn(2,k)+p)**2+
     &         (stn(3,k)+p)**2+
     &         2.d0*(stn(4,k)**2+
     &               stn(5,k)**2+
     &               stn(6,k)**2)))/xstress)
            else
               k=ialset(j-2)
               do
                  k=k-ialset(j)
                  if(k.ge.ialset(j-1)) exit
                  p=-(stn(1,k)+stn(2,k)+stn(3,k))/3.d0
                  g0(iobject)=g0(iobject)+dexp(rho*dsqrt(1.5d0*
     &                 ((stn(1,k)+p)**2+
     &                 (stn(2,k)+p)**2+
     &                 (stn(3,k)+p)**2+
     &                 2.d0*(stn(4,k)**2+
     &                 stn(5,k)**2+
     &                 stn(6,k)**2)))/xstress)
               enddo
            endif
         enddo
         g0(iobject)=dlog(g0(iobject))/rho
      endif
!
      return
      end


C Copyright (C) 2000, International Business Machines
C Corporation and others.  All Rights Reserved.
      SUBROUTINE DFO( N    , NX    , X     , LDX   , FX, IFINIV,
     +                NCLIN, NCNLN , LB    , UB    , A , LDA   ,
     +                LDCJ , XNAMES, PNAME , GNAMES, IT, NF    ,
     +                INFO , WRK   , LWRK  , IWRK  , LIWRK )

C
C  ****************************************************************
C  THIS SUBROUTINE MINIMIZES A NONLINEAR OBJECTIVE FUNCTION
C  SUBJECT TO LINEAR AND (POSSIBLY) NONLINEAR CONSTRAINTS
C  AND SIMPLE BOUNDS, WITHOUT USING DERIVATIVES OF
C  THE OBJECTIVE FUNCTION.
C
C  THE PROBLEM IS CONSIDERED TO BE OF THE FORM
C
C                           MIN F( X )
C
C        S.T.
C                               / X  \
C                        LB <= ( AX   ) <= UB
C                               \C(X)/
C
C  THIS PROGRAM IS BASED ON USING QUADRATIC INTERPOLATION OF THE
C  OBJECTIVE FUNCTION IN COMBINATION WITH TRUST REGION FRAMEWORK
C
C
C  PARAMETERS
C  ==========
C
C  (INPUT)
C
C    X         : ARRAY OF NX  INITIAL POINTS, GIVEN BY THE USER
C                'X' HAS TO CONTAIN AT LEAST ONE STARTING POINT
C                IF NO FUNCTION VALUES ARE PROVIDED FOR THE POINTS
C                IN 'X', THEN ALL BUT THE FIRST POINT ARE IGNORED.
C
C    LDX       : LEADING DIMENSION OF ARRAY 'X' (LDX>= N)
C
C    FX        : ARRAY OF FUNCTION VALUES AT THE INITIAL POINTS
C                OF LENGTH AT LEAST 1 ( MAY BE DUMMY IF NO VALUES
C                ARE PROVIDED )
C
C    NX        : NUMBER OF INITIAL POINTS FOR WHICH THE VALUE IS
C                PROVIDED. IF NO SUCH POINTS PROVIDED, THEN NX=1
C
C    IFINIV    : LOGICAL VARIABLE, .TRUE. IS INITIAL VALUES FOR
C                NX INITIAL POINTS ARE PROVIDED, .FALSE. OTHERWISE
C
C    N         : PROBLEM DIMENSION
C
C    NCLIN     : NUMBER F LINEAR CONSTRAINTS
C
C    NCNLN     : NUMBER OF NONLINEAR CONSTRAINTS
C
C    LB        : ARRAY OF LOWER BOUNDS OF LENGTH >= (N+NCLIN+NCNLN)
C
C    UB        : ARRAY OF UPPER BOUNDS OF LENGTH >= (N+NCLIN+NCNLN)
C
C    A         : MATRIX OF LINEAR CONSTRAINTS,( DIMENSIONS: LDA X N)
C
C    LDA       : LEADING DIMENSION OF MATRIX A, HAS TO BE >= MAX(1, NCLIN)
C
C    LDCJ      : LEADING DIMENSION OF THE JACOBIAN OF NONLINEAR
C                CONSTRAINTS, AS COMPUTED BY THE USER ROUTINE 'FUNCON'
C    XNAMES    : ARRAY OF STRINGS OF CHARACTERS, CONTAINING
C                NAMES OF THE VARIABLES
C
C    PNAME     : STRING OF CHARACTERS CONTAINING THE NAME OF THE PROBLEMS
C
C    GNAMES    : ARRAY OF STRINGS OF CHARACTERS, CONTAINING NAMES
C                OF CONSTRAINTS
C
C    WRK       : REAL WORKSPACE ARRAY OF SIZE LWRK
C                THE REQUIRED LENGTH OF LWRK IS APPROXIMATED FROM ABOVE  BY:
C                (2N+24)(N+NCLIN+NCNLN)+(2NCNLN+6)*N+(MAXNF+NX)(N+2)+
C                [(N+1)**2 (N+2)(N+14)]/4
C
C
C    IWRK      : INTEGER WORKSPACE ARRAY OF SIZE LIWRK
C                THE REQUIRED LENGTH OF INTEGER SPACE IS
C                4((N+NCLIN+NCNLN) + (MAXNF+NX) + (N+1)(N+2)/2
C
C    (OUTPUT)
C
C     X        : THE OPTIMAL (OR BEST FOUND)  POINT
C
C     FX       : THE VALUE OF OBJECTIVE FUNCTION AT X
C
C     INFO     : THE EXIT INFORMATION:
C                0     SUCCESSFUL MINIMIZATION
C                1     TOO MANY FUNCTION EVALUATIONS
C                2     TOO MANY ITERATIONS
C               -1     ILLEGAL VALUE OF N, NCLIN OR NCNLN
C               -2     ILLEGAL VALUE OF LDA OR LDX
C               -3     REAL WORKSPACE IS TOO SMALL
C               -4     INTEGER WORKSPACE IS TOO SMALL
C               -5     INCONSISTENT BOUNDS
C               -6     FUNCTION VALUE CANNOT BE COMPUTED
C                      AT INITIAL POINT
C               -7     MINIMIZATION OVER TRUST REGION FAILED
C               -8     MAXNF IS TOO SMALL, LESS THAN 2
C               -9     CANNOT BUILD A 2 POINT MODEL
C     IT       : THE NUMBER OF ITERATIONS
C
C     NF       : THE NUMBER OF FUNCTION EVALUATIONS
C
C  ********************************************************************
C
C     Programming:  K. Scheinberg, Spring 1998.
C
C  ********************************************************************
C

C
C  SUBROUTINE PARAMETERS
C
      INTEGER          N , NX, LDX , NCLIN, NCNLN, LDA, LDCJ,
     +                 IT, NF, INFO, LWRK , LIWRK, IWRK(LIWRK)

      DOUBLE PRECISION X(LDX*NX), FX(NX), LB(N+NCLIN+NCNLN),
     +                 UB(N+NCLIN+NCNLN), A(LDA*N), WRK(LWRK)

      LOGICAL          IFINIV

      CHARACTER*10     XNAMES(N), PNAME, GNAMES(NCLIN+NCNLN)
C
C  COMMON VARIABLES
C

C
C  PROCESS CONTROL PARAMETERS
C
      INTEGER          IOUT  , IPRINT
      DOUBLE PRECISION MCHEPS, CNSTOL
      COMMON / DFOCM / IOUT  , IPRINT, MCHEPS, CNSTOL

C
C  INTERPOLATION CONTROL PARAMETERS
C
      INTEGER          NPMIN, LAYER, EFFORT
      COMMON / OPTI /  NPMIN, LAYER, EFFORT

C
C  EXTERNAL ROUTINES
C

      DOUBLE PRECISION DDOT

      EXTERNAL         DDOT
C
C  LOCAL VARIABLES
C

      INTEGER          MAXNF , MAXIT , VARNT , IOSPEC, ISCAL,
     +                 IP(6) , BADBND, SCALE , I     , J    ,
     +                 ICURW , LENW  , LSCAL

      DOUBLE PRECISION DELMIN  , LOWBND, ANOISE, RNOISE, PIVTHR,
     +                 ADDTHR  , XCHTHR, RP(7) , DELTA , DELMAX,
     +                 NOISE(2), AVGSC , VAL
      CHARACTER*64     SPECS

      LOGICAL          IFERR
C
C  PARAMETERS
C
      DOUBLE PRECISION ONE, ZERO
      PARAMETER      ( ONE = 1.0D0, ZERO = 0.0D0 )
      INTEGER          INSPEC
      PARAMETER      ( INSPEC = 45 )

C
C  SUBROUTINES CALLED:
C
C  APPLICATIONS: DFOSLV, FUN, SCL, UNSCL, FUNCON
C  BLAS        : DDOT
C

C  ----------------------------------
C  CHECK IF THE INITIAL DATA IS VALID
C  ----------------------------------

C
C  CHECK IF THE DIMENSIONS ARE POSITIVE
C
      IF ( N .LE. 0  ) THEN
         IF (IPRINT .GE. 0 ) WRITE( IOUT, 1000 ) N
         INFO = -1
         RETURN
      ENDIF

      IF ( NCLIN .LT. 0  ) THEN
         IF (IPRINT .GE. 0 ) WRITE( IOUT, 1010 ) NCLIN
         INFO = -1
         RETURN
      ENDIF

      IF (  NCNLN .LT. 0 ) THEN
         IF (IPRINT .GE. 0 ) WRITE( IOUT, 1020 ) NCNLN
         INFO = -1
         RETURN
      ENDIF

C
C  CHECK IF THE  BOUNDS ARE CONSISTENT
C
      BADBND=0
      DO 10 I=1,N+NCLIN+NCNLN
        IF (LB( I ) .GT. UB( I )+MCHEPS) BADBND=1
 10   CONTINUE
      IF (BADBND.EQ.1) THEN
        IF (IPRINT .GE. 0 ) WRITE(IOUT, 1030)
        INFO=-5
        RETURN
      ENDIF

C
C  CHECK IF DIMENSION OF LINEAR CONSTRAINT MATRIX IS SATISFACTORY
C

      IF ( LDA .LT. MAX(NCLIN,1) ) THEN
         IF (IPRINT .GE. 0 ) WRITE(IOUT, 1060) MAX(NCLIN,1)
         INFO = -2
         RETURN
      ENDIF

C
C  CHECK IF DIMENSION OF NONLINEAR CONSTRAINT JACOBIAN IS SATISFACTORY
C

      IF ( LDCJ .LT. MAX(NCNLN,1) ) THEN
         IF (IPRINT .GE. 0 ) WRITE(IOUT, 1065) MAX(NCNLN,1)
         INFO = -2
         RETURN
      ENDIF

C
C  CHECK IF LEADING DIMENSION OF INITIAL SET 'X' IS SATISFACTORY
C

      IF ( LDX .LT. N ) THEN
         IF (IPRINT .GE. 0 ) WRITE(IOUT, 1080) N
         INFO = -2
         RETURN
      ENDIF

C
C  CHECK IF OTHER DIMENSION OF INITIAL SET 'X' IS POSITIVE
C

      IF ( NX .LE. 0 ) THEN
         IF (IPRINT .GE. 0 ) WRITE(IOUT, 1090)
         INFO = -2
         RETURN
      ENDIF

C
C  READ THE SPECIFICATION FILE
C

      SPECS = 'DFO.SPC'
      OPEN( INSPEC , FILE = SPECS, FORM = 'FORMATTED',
     +      STATUS = 'OLD', IOSTAT = IOSPEC )
      REWIND INSPEC
      READ ( INSPEC, 3000 ) DELMIN, DELMAX, DELTA , LOWBND, MAXNF ,
     +                      MAXIT , ANOISE, RNOISE, PIVTHR,
     +                      ADDTHR, XCHTHR, CNSTOL, NPMIN ,
     +                      LAYER , EFFORT, VARNT , SCALE ,
     +                      IPRINT, IOUT

      CLOSE ( INSPEC )
C
C  STORE THE MINIMIZATION PARAMETERS, OBTAINED FROM SPECIFICATION FILE
C

      MCHEPS     = 1.5D-16
      IP( 1 )    = MAXIT
      IP( 2 )    = MAXNF
      IP( 3 )    = NPMIN
      IP( 4 )    = LAYER
      IP( 5 )    = EFFORT
      IP( 6 )    = VARNT
      RP( 1 )    = DELTA
      RP( 2 )    = DELMAX
      RP( 3 )    = DELMIN
      RP( 4 )    = PIVTHR
      RP( 5 )    = ADDTHR
      RP( 6 )    = XCHTHR
      RP( 7 )    = LOWBND
      NOISE( 1 ) = ANOISE
      NOISE( 2 ) = RNOISE

C
C  CHECK IF THE INITIAL NUMBER OF INTERPOLATION POINTS
C  IS NOT LARGER THAN MAXIMUM NUMBER OF FUNCTION EVALUATIONS
C

      IF ( MAXNF .LT. 2 ) THEN
         IF (IPRINT .GE. 0 ) WRITE( IOUT, 1050 ) 2
         INFO = -8
         RETURN
      ENDIF

C
C  PRINT OUT SOME SPECIFICATIONS INFO
C

      IF ( IPRINT .GE. 2 ) THEN
        IF ( VARNT .EQ.1 ) THEN
          WRITE ( IOUT, 4000 )
        ELSE
          WRITE ( IOUT, 4020 )
        ENDIF
      ENDIF
C
C  IF THERE ARE NO NONLINEAR CONSTRAINTS SET THE CONSTRAINT
C  TOLERANCE, USED BY NPSOL, TO A DEFAULT VALUE
C
      IF ( NCNLN .EQ. 0 ) CNSTOL = 1.0D-8

C
C  SET THE POINTERS TO SPACE FOR SCALING COEFFICIENTS
C
      ISCAL = 1
      LSCAL = ISCAL - 1
C
C  CHECK IF REAL SPACE IS SUFFICIENT
C
      ICURW = ISCAL + N
      LENW  = LWRK - ICURW + 1
      IF ( LENW .LT. 0 ) THEN
        WRITE( IOUT, 1070 ) LWRK
        INFO = -3
        RETURN
      ENDIF
C
C INITIALIZE NF TO ZERO.
C IF NO INITIAL POINT WITH FUNCTION VALUE IS PROVIDED, COMPUTE
C THE FUNCTION VALUE AT THE FIRST POINT AND SET NF = 1
C
      NF = 0
      IF ( .NOT. IFINIV ) THEN
        CALL FUN( N, X, FX, IFERR )
        IF ( IFERR ) THEN
          IF (IPRINT .GE. 0 ) WRITE(IOUT, 1040)
          INFO = -6
          RETURN
        ENDIF
        NF = 1
        NX = 1
      ENDIF

C
C  CHECK IF SCALING AND NONLINEAR CONSTRAINTS ARE NOT USED AT
C  THE SAME TIME (NOT SUPPORTED BY CURRENT VERSION)
C
      IF ( SCALE .NE. 0 .AND. NCNLN .GT. 0 ) THEN
         IF (IPRINT .GE. 0 ) WRITE(IOUT, 5000)
         SCALE = 0
      ENDIF

C
C  SCALE THE PROBLEM IF REQUIRED
C

      IF ( SCALE .NE. 0 ) THEN
        AVGSC=ONE
        DO 20 I=1, N
          IF ( SCALE .EQ. 1 ) THEN
            WRK( LSCAL + I ) = ONE + ABS(X(I))
            AVGSC   = AVGSC * WRK( LSCAL + I )
          ELSE
            WRK( LSCAL + I ) = UB(I) - LB(I)
            IF ( WRK( LSCAL + I). LT. CNSTOL .OR. WRK( LSCAL + I )
     +                                       .GT. 1.0D+20 ) THEN
              IF (IPRINT .GE. 0 ) WRITE( IOUT, 5200 )  I
              WRK( LSCAL + I ) = ONE
              AVGSC   = AVGSC * WRK( LSCAL + I )
            ENDIF
          ENDIF
 20     CONTINUE
      ENDIF
C
C  SCALE THE POINT AND THE BOUNDS
C
      IF ( SCALE .NE. 0 ) THEN
        DO 25 I=1,NX
          CALL SCL( N, X((I-1)*N+1), WRK( ISCAL ) )
 25     CONTINUE
        CALL SCL( N, LB, WRK( ISCAL ) )
        CALL SCL( N, UB,  WRK( ISCAL ) )
C
C  SHOULD SCALE THE TRUST REGION RADIUS AS WELL. RIGHT NOW ONLY SCALE
C  THE LOWER BOUND ON THE TRUST REGIONS RADIUS
C

C        RP( 1 ) = RP( 1 )*(N/AVGSC)
C        RP( 2 ) = RP( 2 )*(N/AVGSC)
        RP( 3 ) = RP( 3 )/(EXP(LOG(AVGSC)/N))
        DO 40 I=1,N
          DO 30 J=1,NCLIN
            A(LDA*(I-1)+J)=A(LDA*(I-1)+J)*WRK( LSCAL + I )
 30       CONTINUE
 40     CONTINUE
        IF ( IPRINT .GE. 2 ) THEN
          WRITE( IOUT, 8000 )
          DO 45 I = 1, N
            WRITE( IOUT, 8010 ) WRK( LSCAL + I )
 45       CONTINUE
        ENDIF
      ENDIF

C
C  CALL THE DFO SOLVER
C

      CALL DFOSLV( N     , NX        , NCLIN, NCNLN, X    , LDX  ,
     +             FX    , LB        , UB   , A    , LDA  , LDCJ ,
     +             SCALE , WRK(ISCAL), INFO , IT   , NF   , NOISE,
     +             IP, RP, WRK(ICURW), LENW , IWRK , LIWRK )

C
C  UNSCALE THE PROBLEM IF SCALED
C

      IF (SCALE .NE. 0) THEN
        CALL UNSCL( N, X, WRK(ISCAL) )
        CALL UNSCL( N, LB, WRK(ISCAL) )
        CALL UNSCL( N, UB, WRK(ISCAL) )
        DO 60 I=1,N
          DO 50 J=1,NCLIN
            A(LDA*(J-1)+I)=A(LDA*(J-1)+I)/WRK(LSCAL + I)
 50       CONTINUE
 60     CONTINUE
      ENDIF

C
C  IF DEMANDED, PRINT OUT THE FINAL OUTPUT
C
      IF ( IPRINT .GE. 0 ) THEN
        WRITE ( IOUT, 6000 )
        DO 70 I = 1, N
          WRITE( IOUT, 6200 ) XNAMES(I), X( I )
 70     CONTINUE
        IF ( NCLIN .GT. 0 ) THEN
          WRITE ( IOUT, 6100 )
          DO 80 I = 1, NCLIN
            VAL=DDOT(N, A(I), LDA, X, 1)
            WRITE( IOUT, 6200 ) GNAMES(I), VAL
 80       CONTINUE
        ENDIF
        IF ( NCNLN .GT. 0 ) THEN
          WRITE ( IOUT, 6300 )
          DO 85 I = 1, NCNLN
            IWRK( I ) = 1
 85       CONTINUE
          CALL FUNCON(0, NCNLN  , N, LDCJ  , IWRK   ,
     *                X, WRK(ICURW), WRK(ICURW+LDCJ), 1)
          DO 90 I = 1, NCNLN
            WRITE( IOUT, 6200 ) GNAMES(NCLIN+I), WRK( ICURW+I-1 )
 90       CONTINUE
        ENDIF
        WRITE( IOUT, 6400 )  PNAME, N, NCLIN+NCNLN, NF, IT, FX(1), INFO
C       WRITE( IOUT, 6600 )  PNAME, N, NCLIN+NCNLN, NF, IT, FX(1), INFO
      ENDIF

      RETURN

C
C  NON-EXECUTABLE STATEMENTS
C

 1000 FORMAT(/' DFO: *** ERROR: NUMBER OF VARIABLES',/
     +        '                 HAS ILLEGAL VALUE:', I6,/ )
 1010 FORMAT(/' DFO: *** ERROR: NUMBER OF LINEAR CONSTRAINTS',/
     +        '                 HAS ILLEGAL VALUE:', I6,/)
 1020 FORMAT(/' DFO: *** ERROR: NUMBER OF NONLINEAR CONSTRAINTS',/
     +        '                 HAS ILLEGAL VALUE:', I6,/ )
 1030 FORMAT(/' DFO: *** ERROR: THE UPPER AND LOWER BOUNDS ARE',/,
     +        '                 INCONSISTENT', /)
 1040 FORMAT(/' DFO: *** ERROR: FUNCTION VALUE CANNOT BE OBTAINED',/,
     +        '                 FOR INITIAL POINT!')
 1050 FORMAT(/' DFO: *** ERROR: MAXNF IS TOO SMALL!' /
     +        '                 IT SHOULD BE AT LEAST ', I5 )
 1060 FORMAT(/' DFO: *** ERROR: THE LEADING DIMENSION OF ',/,
     +        '                 LINEAR CONSTRAINTS SHOULD BE AT LEAST',
     +                          I6,/)
 1065 FORMAT(/' DFO: *** ERROR: THE LEADING DIMENSION OF ',/,
     +        '                 NONLINEAR JACOBIAN SHOULD BE AT LEAST',
     +                          I6,/)
 1070 FORMAT('  DFO: *** ERROR: LWRK IS TOO SMALL EVEN TO START!' /
     +        '                 IT IS: ',I10 )
 1080 FORMAT(/' DFO: *** ERROR: THE LEADING DIMENSION OF ',/,
     +        '                 INITIAL SET "X" SHOULD BE AT LEAST',
     +                          I6,/)
 1090 FORMAT(/' DFO: *** ERROR: THE NUMBER  OF INITIAL ',/,
     +        '                 POINTS "X" SHOULD BE POSITIVE')
 3000 FORMAT( 4( D12.4, /), 2( I12, /), 6( D12.4, /), 6(I12, /), I12 )
 5000 FORMAT(/' DFO: *** WARNING: SCALING IS NOT SUPPORTED ',/,
     +        '          FOR PROBLEMS WITH NONLINEAR CONSTRAINTS',/,
     +        '          NO SCALING WILL BE PERFORMED',/)
 5200 FORMAT( ' DFO: *** WARNING:',I4,'-th variable cannot be scaled,'
     +                   ,/,
     +        '          scaling coefficient is too small or',/,
     +        '          too large',/)
 4000 FORMAT( ' Minimum frobenius norm models will be used', / )
 4020 FORMAT( ' Models based on incomplete Newton Polynomial basis',/
     +        ' will be used',/ )

 6000 FORMAT( 'OPTIMAL POINT:', / )
 6100 FORMAT( 'LINEAR CONSTRAINTS:', / )
 6200 FORMAT( A10, D12.6, / )
 6300 FORMAT( 'NONLINEAR CONSTRAINTS:', / )
 6400 FORMAT( /, 24('*'), 'DFO: FINAL OUTPUT ', 24('*') //
     +    ' problem                 =      ', A10,   /,
     +    ' # variables             =      ', I10,   /,
     +    ' # constraints           =      ', I10,   /,
     +    ' # objective functions   =      ', I10,   /,
     +    ' # iterations            =      ', I10,   /,
     +    ' Final f                 =      ', D15.7, /,
     +    ' Exit code               =      ', I10,   /,
     +     65('*') / )
 6600 FORMAT( A8, I10, 1X, I10, 1X, I10, 1X, I10, 1X,  D14.7, 1X, I10 )
 8000 FORMAT( 'SCALING COEFFICIENTS:',/)
 8010 FORMAT( D14.7, 1X )

      END
*


      REAL             FUNCTION SCI (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1998-10-29 SCI Krogh  Moved external statement up for mangle.
c>> 1996-03-30 SCI Krogh  Added external statements.
C>> 1995-11-22 SCI Krogh  Removed multiple entry for C conversion.
C>> 1995-11-03 SCI Krogh  Removed blanks in numbers for C conversion.
c>> 1994-10-20 SCI Krogh  Changes to use M77CON
c>> 1990-01-23 SCI CLL Using name SCIN for result in entry SCIN.
c>> 1989-03-14 Original W. V. Snyder at JPL
C
C     COMPUTE THE COSINE INTEGRAL OF X =
C     INTEGRAL FROM X TO INFINITY OF -(COS(T)/T) DT =
C     GAMMA + LOG(ABS(X)) + INTEGRAL FROM 0 TO X OF ((COS(T)-1)/T DT),
C     WHERE GAMMA IS EULER'S CONSTANT.
C
C     FOR ABS(X)<16, USE A CHEBYSHEV SERIES WITH ARGUMENT 2*Z*Z-1 WHERE
C     Z=X/16 TO EVALUATE (CI(X)-LOG(ABS(X))-GAMMA)/(Z*Z), THEN MULTIPLY
C     THE RESULT BY Z*Z AND ADD LOG(ABS(X)) AND GAMMA.  LOSS OF ABOUT
C     TWO DIGITS OCCURS NEAR ABS(X)=16 DUE TO CANCELLATION.
C
C     FOR ABS(X).GE.16, USE CHEBYSHEV SERIES WITH ARGUMENT 2*Z*Z-1 WHERE
C     WHERE Z=16/X ARE USED TO COMPUTE F(X)/Z AND G(X)/(Z*Z).  THEN
C     CI(X)=F(X)*SIN(X)-G(X)*COS(X).
C
C     THIS ALGORITHM YIELDS AT MOST 15 DIGITS OF PRECISION.
C
C--S replaces "?": ?CI, ?CII, ?CIN, ?CPVAL, ?ERM1
C
      EXTERNAL SCII
      REAL             X, SCII
      SCI = SCII(.true., X)
      end
C
      REAL             FUNCTION SCIN (X)
      EXTERNAL SCII
      REAL             X, SCII
      SCIN = SCII(.false., X)
      end
c
      REAL             FUNCTION SCII (LDCI, X)
      LOGICAL LDCI
      INTEGER ERRLEV
      PARAMETER (ERRLEV=0)
      EXTERNAL SCPVAL
      REAL             C(23), SCPVAL, F(13), G(13), GAMMA,X, Z,ZW
      parameter(GAMMA = 0.577215664901533E0)
      DATA C/
     1 + 0.5E0,                  + 0.5E0,
     2 +14.992589367813409E0, -19.386124096607770E0,
     3 +12.741870869758071E0, - 8.107903970562531E0,
     4 + 4.862022348500627E0, - 2.497505088539025E0,
     5 + 1.008660787358110E0, - 0.312080924825428E0,
     6 + 0.074678255294576E0, - 0.014110865253535E0,
     7 + 0.002152046752074E0, - 0.000270212331184E0,
     8 + 0.000028416945498E0, - 0.000002540125611E0,
     9 + 0.000000195437144E0, - 0.000000013084020E0,
     A + 0.000000000769379E0, - 0.000000000040066E0,
     B + 0.000000000001861E0, - 0.000000000000078E0,
     C + 0.000000000000003E0/
      DATA F/
     1 + 0.5E0,                  + 0.5E0,
     2 + 0.062263729028927E0, - 0.000233756041393E0,
     3 + 0.000002453755677E0, - 0.000000058670317E0,
     4 + 0.000000002356196E0, - 0.000000000136096E0,
     5 + 0.000000000010308E0, - 0.000000000000964E0,
     6 + 0.000000000000107E0, - 0.000000000000014E0,
     7 + 0.000000000000002E0/
      DATA G/
     1 + 0.5E0,                  + 0.5E0,
     2 + 0.003862856096703E0, - 0.000042644182622E0,
     3 + 0.000000724995950E0, - 0.000000023468225E0,
     4 + 0.000000001169202E0, - 0.000000000079604E0,
     5 + 0.000000000006875E0, - 0.000000000000717E0,
     6 + 0.000000000000087E0, - 0.000000000000012E0,
     7 + 0.000000000000002E0/
C
      IF (LDCI) then
         IF (X.LE.0.0) THEN
            CALL SERM1('SCI',1,ERRLEV,'Argument not positive','X',X,'.')
C        Provide a value in case the error message processor returns.
            SCII = 0.0
         ELSE IF (X.LT.16.0) THEN
            Z = X/16.0
            ZW = Z*Z
            SCII = LOG(X) - ZW*SCPVAL(C,20,ZW) + GAMMA
         ELSE
            Z = 16.0/X
            ZW = Z*Z
            SCII = Z*(SCPVAL(F,10,ZW)*SIN(X) - Z*SCPVAL(G,10,ZW)*COS(X))
         END IF
      ELSE
C
C     Evaluate the entire function
C     Cin(x) = Integral from 0 to x of ((cos(t) - 1) / t) dt.
C
         IF (ABS(X).LT.16.0) THEN
            Z = X/16.0
            ZW = Z*Z
            SCII = ZW*SCPVAL(C,20,ZW)
         ELSE
            Z = 16.0/X
            ZW = Z*Z
            SCII = LOG(ABS(X)) + GAMMA -
     1         Z*(SCPVAL(F,10,ZW)*SIN(X) - Z*SCPVAL(G,10,ZW)*COS(X))
         END IF
      END IF
      RETURN
      END


! { dg-do run }
! { dg-options "-std=gnu" }
! PR fortran/29391
! This file is here to check that LBOUND and UBOUND return correct values
!
! Contributed by Francois-Xavier Coudert (coudert@clipper.ens.fr)
  implicit none
  integer, allocatable :: i(:,:), j(:), u(:,:,:,:)

  allocate (i(-1:1,-1:1))
  i = 0
  allocate (j(-1:2))
  j = 0
  allocate (u(7,4,2,9))

  call foo(u,4)
  call jackal(-1,-8)
  call jackal(-1,8)

  if (any(lbound(i(-1:1,-1:1)) /= 1)) call abort
  if (lbound(i(-1:1,-1:1), 1) /= 1) call abort
  if (lbound(i(-1:1,-1:1), 2) /= 1) call abort

  if (any(ubound(i(-1:1,-1:1)) /= 3)) call abort
  if (ubound(i(-1:1,-1:1), 1) /= 3) call abort
  if (ubound(i(-1:1,-1:1), 2) /= 3) call abort

  if (any(lbound(i(:,:)) /= 1)) call abort
  if (lbound(i(:,:), 1) /= 1) call abort
  if (lbound(i(:,:), 2) /= 1) call abort

  if (any(ubound(i(:,:)) /= 3)) call abort
  if (ubound(i(:,:), 1) /= 3) call abort
  if (ubound(i(:,:), 2) /= 3) call abort

  if (any(lbound(i(0:,-1:)) /= 1)) call abort
  if (lbound(i(0:,-1:), 1) /= 1) call abort
  if (lbound(i(0:,-1:), 2) /= 1) call abort

  if (any(ubound(i(0:,-1:)) /= [2,3])) call abort
  if (ubound(i(0:,-1:), 1) /= 2) call abort
  if (ubound(i(0:,-1:), 2) /= 3) call abort

  if (any(lbound(i(:0,:0)) /= 1)) call abort
  if (lbound(i(:0,:0), 1) /= 1) call abort
  if (lbound(i(:0,:0), 2) /= 1) call abort

  if (any(ubound(i(:0,:0)) /= 2)) call abort
  if (ubound(i(:0,:0), 1) /= 2) call abort
  if (ubound(i(:0,:0), 2) /= 2) call abort

  if (any(lbound(transpose(i)) /= 1)) call abort
  if (lbound(transpose(i), 1) /= 1) call abort
  if (lbound(transpose(i), 2) /= 1) call abort

  if (any(ubound(transpose(i)) /= 3)) call abort
  if (ubound(transpose(i), 1) /= 3) call abort
  if (ubound(transpose(i), 2) /= 3) call abort

  if (any(lbound(reshape(i,[2,2])) /= 1)) call abort
  if (lbound(reshape(i,[2,2]), 1) /= 1) call abort
  if (lbound(reshape(i,[2,2]), 2) /= 1) call abort

  if (any(ubound(reshape(i,[2,2])) /= 2)) call abort
  if (ubound(reshape(i,[2,2]), 1) /= 2) call abort
  if (ubound(reshape(i,[2,2]), 2) /= 2) call abort

  if (any(lbound(cshift(i,-1)) /= 1)) call abort
  if (lbound(cshift(i,-1), 1) /= 1) call abort
  if (lbound(cshift(i,-1), 2) /= 1) call abort

  if (any(ubound(cshift(i,-1)) /= 3)) call abort
  if (ubound(cshift(i,-1), 1) /= 3) call abort
  if (ubound(cshift(i,-1), 2) /= 3) call abort

  if (any(lbound(eoshift(i,-1)) /= 1)) call abort
  if (lbound(eoshift(i,-1), 1) /= 1) call abort
  if (lbound(eoshift(i,-1), 2) /= 1) call abort

  if (any(ubound(eoshift(i,-1)) /= 3)) call abort
  if (ubound(eoshift(i,-1), 1) /= 3) call abort
  if (ubound(eoshift(i,-1), 2) /= 3) call abort

  if (any(lbound(spread(i,1,2)) /= 1)) call abort
  if (lbound(spread(i,1,2), 1) /= 1) call abort
  if (lbound(spread(i,1,2), 2) /= 1) call abort

  if (any(ubound(spread(i,1,2)) /= [2,3,3])) call abort
  if (ubound(spread(i,1,2), 1) /= 2) call abort
  if (ubound(spread(i,1,2), 2) /= 3) call abort
  if (ubound(spread(i,1,2), 3) /= 3) call abort

  if (any(lbound(maxloc(i)) /= 1)) call abort
  if (lbound(maxloc(i), 1) /= 1) call abort

  if (any(ubound(maxloc(i)) /= 2)) call abort
  if (ubound(maxloc(i), 1) /= 2) call abort

  if (any(lbound(minloc(i)) /= 1)) call abort
  if (lbound(minloc(i), 1) /= 1) call abort

  if (any(ubound(minloc(i)) /= 2)) call abort
  if (ubound(minloc(i), 1) /= 2) call abort

  if (any(lbound(maxval(i,2)) /= 1)) call abort
  if (lbound(maxval(i,2), 1) /= 1) call abort

  if (any(ubound(maxval(i,2)) /= 3)) call abort
  if (ubound(maxval(i,2), 1) /= 3) call abort

  if (any(lbound(minval(i,2)) /= 1)) call abort
  if (lbound(minval(i,2), 1) /= 1) call abort

  if (any(ubound(minval(i,2)) /= 3)) call abort
  if (ubound(minval(i,2), 1) /= 3) call abort

  if (any(lbound(any(i==1,2)) /= 1)) call abort
  if (lbound(any(i==1,2), 1) /= 1) call abort

  if (any(ubound(any(i==1,2)) /= 3)) call abort
  if (ubound(any(i==1,2), 1) /= 3) call abort

  if (any(lbound(count(i==1,2)) /= 1)) call abort
  if (lbound(count(i==1,2), 1) /= 1) call abort

  if (any(ubound(count(i==1,2)) /= 3)) call abort
  if (ubound(count(i==1,2), 1) /= 3) call abort

  if (any(lbound(merge(i,i,.true.)) /= 1)) call abort
  if (lbound(merge(i,i,.true.), 1) /= 1) call abort
  if (lbound(merge(i,i,.true.), 2) /= 1) call abort

  if (any(ubound(merge(i,i,.true.)) /= 3)) call abort
  if (ubound(merge(i,i,.true.), 1) /= 3) call abort
  if (ubound(merge(i,i,.true.), 2) /= 3) call abort

  if (any(lbound(lbound(i)) /= 1)) call abort
  if (lbound(lbound(i), 1) /= 1) call abort

  if (any(ubound(lbound(i)) /= 2)) call abort
  if (ubound(lbound(i), 1) /= 2) call abort

  if (any(lbound(ubound(i)) /= 1)) call abort
  if (lbound(ubound(i), 1) /= 1) call abort

  if (any(ubound(ubound(i)) /= 2)) call abort
  if (ubound(ubound(i), 1) /= 2) call abort

  if (any(lbound(shape(i)) /= 1)) call abort
  if (lbound(shape(i), 1) /= 1) call abort

  if (any(ubound(shape(i)) /= 2)) call abort
  if (ubound(shape(i), 1) /= 2) call abort

  if (any(lbound(product(i,2)) /= 1)) call abort
  if (any(ubound(product(i,2)) /= 3)) call abort
  if (any(lbound(sum(i,2)) /= 1)) call abort
  if (any(ubound(sum(i,2)) /= 3)) call abort
  if (any(lbound(matmul(i,i)) /= 1)) call abort
  if (any(ubound(matmul(i,i)) /= 3)) call abort
  if (any(lbound(pack(i,.true.)) /= 1)) call abort
  if (any(ubound(pack(i,.true.)) /= 9)) call abort
  if (any(lbound(unpack(j,[.true.],[2])) /= 1)) call abort
  if (any(ubound(unpack(j,[.true.],[2])) /= 1)) call abort

  call sub1(i,3)
  call sub1(reshape([7,9,4,6,7,9],[3,2]),3)
  call sub2

contains

  subroutine sub1(a,n)
    integer :: n, a(2:n+1,4:*)

    if (any([lbound(a,1), lbound(a,2)] /= [2, 4])) call abort
    if (any(lbound(a) /= [2, 4])) call abort
  end subroutine sub1

  subroutine sub2
    integer :: x(3:2, 1:2)

    if (size(x) /= 0) call abort
    if (lbound (x, 1) /= 1 .or. lbound(x, 2) /= 1) call abort
    if (any (lbound (x) /= [1, 1])) call abort
    if (ubound (x, 1) /= 0 .or. ubound(x, 2) /= 2) call abort
    if (any (ubound (x) /= [0, 2])) call abort
  end subroutine sub2

  subroutine sub3
    integer :: x(4:5, 1:2)

    if (size(x) /= 0) call abort
    if (lbound (x, 1) /= 4 .or. lbound(x, 2) /= 1) call abort
    if (any (lbound (x) /= [4, 1])) call abort
    if (ubound (x, 1) /= 4 .or. ubound(x, 2) /= 2) call abort
    if (any (ubound (x) /= [4, 2])) call abort
  end subroutine sub3

  subroutine foo (x,n)
    integer :: x(7,n,2,*), n

    if (ubound(x,1) /= 7 .or. ubound(x,2) /= 4 .or. ubound(x,3) /= 2) call abort
  end subroutine foo

  subroutine jackal (b, c)
    integer :: b, c
    integer :: soda(b:c, 3:4)

    if (b > c) then
      if (size(soda) /= 0) call abort
      if (lbound (soda, 1) /= 1 .or. ubound (soda, 1) /= 0) call abort
    else
      if (size(soda) /= 2*(c-b+1)) call abort
      if (lbound (soda, 1) /= b .or. ubound (soda, 1) /= c) call abort
    end if

    if (lbound (soda, 2) /= 3 .or. ubound (soda, 2) /= 4) call abort
    if (any (lbound (soda) /= [lbound(soda,1), lbound(soda,2)])) call abort
    if (any (ubound (soda) /= [ubound(soda,1), ubound(soda,2)])) call abort

  end subroutine jackal

end


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   ab :            The A --> B reaction
!----------------------------------------------------------------------
!----------------------------------------------------------------------

      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!     ---------- ----

! Evaluates the algebraic equations or ODE right hand side

! Input arguments :
!      NDIM   :   Dimension of the ODE system
!      U      :   State variables
!      ICP    :   Array indicating the free parameter(s)
!      PAR    :   Equation parameters

! Values to be returned :
!      F      :   ODE right hand side values

! Normally unused Jacobian arguments : IJAC, DFDU, DFDP (see manual)

      IMPLICIT NONE
      INTEGER NDIM, IJAC, ICP(*)
      DOUBLE PRECISION U(NDIM), PAR(*), F(NDIM), DFDU(*), DFDP(*)
      DOUBLE PRECISION U1,U2,E

       U1=U(1)
       U2=U(2)

       E=EXP(U2)

       F(1)=-U1 + PAR(1)*(1-U1)*E
       F(2)=-U2 + PAR(1)*PAR(2)*(1-U1)*E - PAR(3)*U2

      END SUBROUTINE FUNC
!----------------------------------------------------------------------
!----------------------------------------------------------------------

      SUBROUTINE STPNT(NDIM,U,PAR,T)
!     ---------- -----

! Input arguments :
!      NDIM   :   Dimension of the ODE system

! Values to be returned :
!      U      :   A starting solution vector
!      PAR    :   The corresponding equation-parameter values
!      T      :	  Not used here

      IMPLICIT NONE
      INTEGER NDIM
      DOUBLE PRECISION U(NDIM), PAR(*), T

! Initialize the equation parameters
       PAR(1)=0.
       PAR(2)=8.
       PAR(3)=3.

! Initialize the solution
       U(1)=0.
       U(2)=0.

      END SUBROUTINE STPNT
!----------------------------------------------------------------------
!----------------------------------------------------------------------
! The following subroutines are not used here,
! but they must be supplied as dummy routines

      SUBROUTINE BCND
      END SUBROUTINE BCND

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT

      SUBROUTINE PVLS
      END SUBROUTINE PVLS
!----------------------------------------------------------------------
!----------------------------------------------------------------------


      subroutine periodic_setprob()
      implicit none

      double precision pi,  pi2
      common /compi/ pi, pi2

      double precision ubar, vbar
      common /comrp/ ubar,vbar

      pi = 4.d0*datan(1.d0)
      pi2 = 2.d0*pi

      open(unit=7,file='setprob.data',status='old',form='formatted')
      read(7,*) ubar
      read(7,*) vbar
      close(7)

      end


      subroutine clawpack46_setaux(maxmx,maxmy,mbc,mx,my,
     &      xlower,ylower,dx,dy,maux,aux)
      implicit none

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

      integer i, j
      double precision xll, yll, psi

      do i = 1-mbc,mx+mbc
         do j = 1-mbc,my+mbc
c           # coordinates of lower left corner of grid cell:
            xll = xlower + (i-1)*dx
            yll = ylower + (j-1)*dy

c           # difference stream function psi to get normal velocities:
            aux(i,j,1) = (psi(xll, yll+dy) - psi(xll,yll)) / dy
            aux(i,j,2) = -(psi(xll+dx, yll) - psi(xll,yll)) / dx
         enddo
      enddo

      return
      end


! ============================ Module Description ===========================
! quasigeostrophic_mod stores experiment parameters and subroutines for
! evaluating Linear and Nonlinear Operators for the quasigeostrophic equation
! when solving in Fourier space (Diagonal Lambda).
!
! Contains 5 subroutines:
!   1. init         - initializes spatial grid, fft plans, experiment
!                     parameters.
!   2. ic           - sets initial condition in physical space
!   3. L            - returns diagonal entries of linear operator Lambda
!   4. N            - subroutine for evaluating nonlinear operator
!   5. buildDiffMat - build relevant differentiation matrices
!   6. error_filter - defines error function used for numerical experiments
! ===========================================================================

module quasigeostrophic_mod

    ! Module Parameters
    use tools_mod, only: dp, PI, II, logspace, plinspace, fourierwavenum, meshgrid, relerror_c, antialias2d
    implicit none
    ! Numerical Parameters
    integer,    parameter :: Nx                   = 2**9                          ! Number of x spatial points (Must be Even)
    integer,    parameter :: Ny                   = 2**9                          ! Number of y spatial points (Must be Even)
    integer,    parameter :: Np                   = Nx * Ny                       ! Total Number of spatial points
    real(dp),   parameter :: tspan(2)             = [ 0.0_dp, 5.0_dp ]            ! Time integration window
    logical,    parameter :: reference_methods(3) = [ .true., .true., .false. ]   ! Methods for Reference Solution (ETDSDC,IMEXSDC,ETDRK)
    integer,    parameter :: num_tests            = 16                            ! Number of Numerical Tests
    real,       parameter :: smallest_F           = 1.5e3_dp                      ! Smallest Number of Function Evaluations
    real,       parameter :: largest_F            = 1.0e5_dp                      ! Maximum Number of Function Evaluations
    logical,    parameter :: antialiasing_enabled = .true.                        ! determines if 2/3 antialiasing rule should be applied.
    ! Storage Arrays
    real(dp), parameter :: Lx       = 2.0_dp * PI
    real(dp), parameter :: Ly       = 2.0_dp * PI
    real(dp), parameter :: epsilon  = 1.0e-2_dp
    real(dp), parameter :: v        = 1.0e-14_dp
    real(dp), parameter :: beta     = 10.0_dp
    character(len=*), parameter :: eqn_name = "quasigeostrophic"                   ! Used to save results to correct folder
    ! Storage Arrays
    complex(dp), dimension(:), allocatable   :: y0
    real(dp),    dimension(:,:), allocatable :: xs,ys
    complex(dp), dimension(:,:,:), allocatable :: P_H, P_LAP, N_temp
    complex(dp), dimension(:, :, :), allocatable :: y, yh
    ! Diff Matrices
    complex(dp), dimension(:,:), allocatable :: DX, DY, LAP, ILAP
    ! FFT Parameters
    integer(kind=8), allocatable :: plan_backward(:), plan_forward(:)
    include "fftw3.f90"
    ! Additional Settings
    real(dp), allocatable :: Fs(:) ! Function Counts to test (set in init function)

    contains

    subroutine init(max_num_threads)
        ! arguments
        integer, intent(in), optional :: max_num_threads
        ! variables
        integer     :: i, nt
        real(dp)    :: k,s
        real(dp)    :: h = Lx/Nx
        real(dp), allocatable :: xsr(:), ysr(:)
        if(present(max_num_threads)) then
            nt = max_num_threads
        else
            nt = 1
        endif
        ! Init FFT plans
        allocate(y(Nx, Ny, nt), yh(Nx, Ny, nt), plan_backward(nt), plan_forward(nt))
        do i = 1, nt
            call dfftw_plan_dft_2d_ (plan_forward(i), Nx, Ny, y(:, :, i), yh(:, :, i), FFTW_FORWARD, FFTW_MEASURE)
            call dfftw_plan_dft_2d_ (plan_backward(i), Nx, Ny, yh(:, :, i), y(:, :, i), FFTW_BACKWARD, FFTW_MEASURE)
        end do
        ! allocate arrays
        allocate(xs(Nx,Ny), ys(Nx,Ny), P_H(Nx,Ny,nt), P_LAP(Nx,Ny,nt), N_temp(Nx,Ny,nt))
        allocate(xsr(Nx),ysr(Ny),y0(Np))
        ! setup spatial domain
        xsr = plinspace(-Lx/2.0_dp,Lx/2.0_dp,Nx)
        ysr = plinspace(-Ly/2.0_dp,Ly/2.0_dp,Ny)
        call meshgrid(xsr,ysr,xs,ys)
        ! Set Differentiation Matrices
        call buildDiffMat()
        ! Set Initial condition
        call ic()
        ! Set Function Evalutations for tests
        Fs = logspace(log(smallest_f)/log(10.0_dp),log(largest_F)/log(10.0_dp),num_tests)
    end subroutine

    ! Form Initial Condition
    subroutine ic()
        y(:,:,1) = (1.0_dp/8.0_dp) * exp(-8.0_dp*(2.0_dp*ys**2.0_dp + 0.5_dp*xs**2.0_dp - PI/4.0_dp)**2.0_dp)
        call dfftw_execute(plan_forward(1))
        if(antialiasing_enabled) then
            call antialias2d(yh(:,:,1))
        endif
        y0 = reshape(LAP * yh(:,:,1), [ Nx * Ny ] )
    end subroutine ic

    subroutine L(lambda)
        complex(dp), dimension(Np), intent(out) :: lambda
        complex(dp), allocatable :: l2d(:,:)

        allocate(l2d(Nx, Ny))
        l2d = -1.0_dp*beta*DX*ILAP - epsilon - v*(DX**8 + DY**8)
        if(antialiasing_enabled) then
            call antialias2d(l2d)
        endif

        lambda = reshape(l2d, [ Np  ])
    end subroutine L

    ! Nonlinear Operator
    subroutine N(t,LAP_P_H_in, N_out, thread_id)
        complex(dp),    intent(in) :: t
        complex(dp), dimension(:), intent(in)  :: LAP_P_H_in !Fourier transform of Laplacian if Phi
        complex(dp), dimension(:), intent(out) :: N_out
        integer, intent(in), optional :: thread_id
        integer :: i, j, tid
        if(present(thread_id)) then
            tid = thread_id
        else
            tid = 1
        endif
        yh(:,:,tid) = reshape(LAP_P_H_in, [Nx, Ny])
        ! Fourier Transform of Phi
        P_H(:,:,tid) = ILAP * yh(:,:,tid)
        ! Laplacian of Phi
        call dfftw_execute(plan_backward(tid))
        P_LAP(:,:,tid) = (1.0_dp/Np) * y(:,:,tid)
        ! Compute N1
        yh(:,:,tid) = -Dy * P_H(:,:,tid)
        call dfftw_execute(plan_backward(tid))
        y(:,:,tid)  = (1.0_dp/Np) * y(:,:,tid) * P_LAP(:,:,tid)
        call dfftw_execute(plan_forward(tid))
        N_temp(:,:,tid)  = -DX * yh(:,:,tid)
        ! Compute N2
        yh(:,:,tid) = Dx * P_H(:,:,tid)
        call dfftw_execute(plan_backward(tid))
        y(:,:,tid)  = (1.0_dp/Np) * y(:,:,tid) * P_LAP(:,:,tid)
        call dfftw_execute(plan_forward(tid))
        N_temp(:,:,tid) = N_temp(:,:,tid) - (DY * yh(:,:,tid))
        if(antialiasing_enabled) then
            call antialias2d(N_temp(:,:,tid))
        endif
        N_out  = reshape(N_temp(:,:,tid),[Np])
    end subroutine N

    ! Differention Matrices
    subroutine buildDiffMat()
        real(dp), allocatable :: k_x(:), k_y(:)
        integer :: i
        allocate(DX(NX,NY), DY(NX,NY), LAP(NX,NY), ILAP(NX,NY))
        ! Get Fourier wave numbers
        k_x = fourierWaveNum(Nx,Lx)
        k_y = fourierWaveNum(Ny,Ly)
        ! Form Discrete D/DX Diff matrix
        do i=1,nx
            DX(:,i) = II * k_x(i)
        enddo
        ! Form Discrete D/DY Diff matrix
        do i=1,nx
            DY(i,:) = II * k_y(i)
        enddo
        LAP  = DX**2 + DY**2        ! Laplacian operator
        ILAP = 1.0_dp/LAP           ! Inverse Laplacian
        ILAP(1,1) = (0.0_dp,0.0_dp) ! Set (0,0) mode to zero
    end subroutine buildDiffMat

    ! Error Filter (Inf norm in physical space)
    function error_filter(estimate,exact) result(error)

        complex(dp), intent(in)  :: estimate(Np)
        complex(dp), intent(in)  :: exact(Np)

        real(dp)  :: error
        complex(dp), allocatable :: a(:),b(:)

        allocate(a(Np),b(Np))

        ! IFFT of estimate
        yh(:,:,1) = (1.0_dp / Np) * reshape(estimate, [Nx, Ny])
        call dfftw_execute(plan_backward(1))
        a(:) = reshape(y(:,:,1),[Np])

        ! IFFT of exact
        yh(:,:,1) = (1.0_dp / Np) * reshape(exact, [Nx, Ny])
        call dfftw_execute(plan_backward(1))
        b(:) = reshape(y(:,:,1),[Np])

        error = relerror_c(a,b)
    end function error_filter

end module quasigeostrophic_mod


subroutine dim_loop(i, j, k, FlatTilde, U, )

  integer, intent(in) :: i, j, k
  FlatTilde
  real, pointer, dimension(:,:,:,:) :: U
  integer :: dir ! rename

  do dir=1,NDIM
     select case (dir)
     case (DIR_X)
        dp1   = (U(PRES_VAR,i+1,j,k)-U(PRES_VAR,i-1,j,k))
        dp2   = (U(PRES_VAR,i+2,j,k)-U(PRES_VAR,i-2,j,k))
        dv1   =  U(VELX_VAR,i+1,j,k)-U(VELX_VAR,i-1,j,k)
        presL =  U(PRES_VAR,i-1,j,k)
        presR =  U(PRES_VAR,i+1,j,k)
  #if NDIM > 1
     case (DIR_Y)
        dp1   = (U(PRES_VAR,i,j+1,k)-U(PRES_VAR,i,j-1,k))
        dp2   = (U(PRES_VAR,i,j+2,k)-U(PRES_VAR,i,j-2,k))
        dv1   =  U(VELY_VAR,i,j+1,k)-U(VELY_VAR,i,j-1,k)
        presL =  U(PRES_VAR,i,j-1,k)
        presR =  U(PRES_VAR,i,j+1,k)
  #if NDIM > 2
     case (DIR_Z)
        dp1   = (U(PRES_VAR,i,j,k+1)-U(PRES_VAR,i,j,k-1))
        dp2   = (U(PRES_VAR,i,j,k+2)-U(PRES_VAR,i,j,k-2))
        dv1   =  U(VELZ_VAR,i,j,k+1)-U(VELZ_VAR,i,j,k-1)
        presL =  U(PRES_VAR,i,j,k-1)
        presR =  U(PRES_VAR,i,j,k+1)
  #endif
  #endif
     end select

     if (abs(dp2) > 1.e-15) then
        Sp = dp1/dp2 - 0.75
     else
        Sp = 0.
     endif

     FlatTilde(dir,i,j,k) = max(0.0, min(1.0,10.0*Sp))
     if ((abs(dp1)/min(presL,presR) < 1./3.) .or. dv1 > 0. ) then
        FlatTilde(dir,i,j,k) = 0.
     endif

  enddo

end subroutine


	SUBROUTINE SNDSCR ( nparms, nlevel, wavlen, wavspd, delz,
     +			    hdata, iret )
C************************************************************************
C* SNDSCR								*
C*									*
C* This routine computes the Scorer Parameter.				*
C*									*
C* SNDSCR ( NPARMS, NLEVEL, WAVLEN, WAVSPD, DELZ, HDATA, IRET )		*
C*									*
C* Input parameters:							*
C*	NPARMS		INTEGER		Number of parameters		*
C*	NLEVEL		INTEGER		Number of levels		*
C*	WAVLEN		CHAR*		Length of wave			*
C*	WAVSPD		CHAR*		Speed of wave			*
C*	DELZ		CHAR*		Height interval			*
C*									*
C* Input/Output parameters:						*
C*	HDATA (LLMXLV)	REAL		Interpolated sounding data	*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal			*
C**									*
C* Log:									*
C* S. Jacobs/SSAI	 4/92						*
C* J. Whistler/SSAI	 4/93		Cleaned up header		*
C* J. Whistler/SSAI	 6/93		Wavlen inputed in KM		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'sndiag.prm'
C*
	CHARACTER*(*)	wavlen, wavspd, delz
	REAL		hdata(*)
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
C
	CALL ST_CRNM ( wavlen, wvln, ier )
	IF  ( ( ier .ne. 0 ) .or. ( wvln .eq. 99999. ) ) THEN
	    wvln = 500.
	ELSE
	    wvln = wvln * 1000.
	END IF
C
	CALL ST_CRNM ( wavspd, wspd, ier )
	IF  ( ier .ne. 0 )  wspd = 0.
C
	CALL ST_CRNM ( delz, deltaz, ier )
	IF  ( ier .ne. 0 )  deltaz = 500.
C
C*	Loop over all levels filling the appropriate sections of the
C*	data array.
C
	ivcord = 3
	DO  k = 2, nlevel-1
c	    clev = hdata((k-1)*nparms+IHGHT)
C
C*	    Compute the Brunt-Vaisala Freq squared.
C
c	    bvfqsq = SND_BVS ( hdata, nparms, clev, deltaz, ivcord )
	    bvfqsq = SND_BVS ( hdata, nparms, k, deltaz, ivcord )
	    richno = SND_RCH ( hdata, nparms, k, deltaz, ivcord )
	    rrchno = SND_RRC ( hdata, nparms, k, deltaz, ivcord )
	    shrdab = SND_SHD ( hdata, nparms, k, deltaz, ivcord )
	    shrmab = SND_SHM ( hdata, nparms, k, deltaz, ivcord )
C
C*	    Check for missing data.
C
	    IF  ( (deltaz .le. 0.0) .or.
     +	    	  ERMISS ( hdata((k-1-1)*nparms+IUWND) ) .or.
     +	    	  ERMISS ( hdata((k-1  )*nparms+IUWND) ) .or.
     +		  ERMISS ( hdata((k-1+1)*nparms+IUWND) ) .or.
     +	    	  ERMISS ( bvfqsq ) )  THEN
C
C*	    	Get next level.
C
		hdata((k-1)*nparms+ISCOR) = RMISSD
		hdata((k-1)*nparms+ISCR1) = RMISSD
		hdata((k-1)*nparms+ISCR2) = RMISSD
		hdata((k-1)*nparms+IUCVR) = RMISSD
		hdata((k-1)*nparms+IBVIN) = RMISSD
		hdata((k-1)*nparms+IBVFQ) = RMISSD
		hdata((k-1)*nparms+IRICH) = RMISSD
		hdata((k-1)*nparms+IRRCH) = RMISSD
		hdata((k-1)*nparms+ISHRD) = RMISSD
		hdata((k-1)*nparms+ISHRM) = RMISSD
	    ELSE
C
C*	        Compute the wind curvature of the U-component.
C
		ucvrot = ( hdata((k-1+1)*nparms+IUWND) -
     +		           2. * hdata((k-1)*nparms+IUWND) +
     +		           hdata((k-1-1)*nparms+IUWND))/(deltaz*deltaz)
C
C*	    	Check for critical levels.
C
		IF  ( ABS(hdata((k-1)*nparms+IUWND)-wspd) .le. 1e-3 )
     +			hdata((k-1)*nparms+IUWND) =
     +			    hdata((k-1)*nparms+IUWND) + .01
C
		denom1 = hdata((k-1)*nparms+IUWND) - wspd
C
C*	    	Compute the first term in the calculation.
C
		term1  = bvfqsq / (denom1*denom1)
C
C*		Compute the second term of the calculation.
C
		term2 = ucvrot * ( -1. / denom1 )
C
C*	    	Compute the wave number from the wavelength.
C*		Compute the third term of the calculation.
C
		IF  ( wvln .eq. 99999. )  THEN
		    wavenum = 99999.
		    term3   = 0.
		ELSE
		    wavenum = ( 2. * PI ) / ( wvln * 1000. )
		    term3   = -1. * wavenum * wavenum
		END IF
C
C*	    	Compute the Scorer parameter and scale it.
C
		scorer = term1 + term2 + term3
C
C*		Compute the Brunt-Vaisala freq / Intrinsic freq.
C
		IF ( wavenum .ne. 99999. ) THEN
		    bvin = SQRT(term1) / wavenum
		ELSE
		    bvin = RMISSD
		END IF
C
C*		Set the data array values to the computed values.
C
		hdata((k-1)*nparms+ISCOR) = scorer * 1e6
		hdata((k-1)*nparms+ISCR1) = term1  * 1e6
		hdata((k-1)*nparms+ISCR2) = term2  * 1e6
		hdata((k-1)*nparms+IUCVR) = ucvrot * 1e6
		hdata((k-1)*nparms+IBVIN) = bvin
		hdata((k-1)*nparms+IBVFQ) = SQRT( bvfqsq ) * 1e2
		hdata((k-1)*nparms+IRICH) = richno
		hdata((k-1)*nparms+IRRCH) = rrchno
		hdata((k-1)*nparms+ISHRD) = shrdab
		hdata((k-1)*nparms+ISHRM) = shrmab
	    END IF
	END DO
C*
	RETURN
	END


      SUBROUTINE lonlat2xy(lon0,lat0,beta,lon1,lat1,x1,y1)
c     Convert lon, lat to Cartesian coordinates
c     lon0, lat0: reference location
c     beta: angle of x axis from east (counterclockwise)
      real lon0,lat0,lon1,lat1,x1,y1,beta
      real xx, yy
c      common/b/ ipolar, nnx, nny, nnz, re, pi, r2d, nnzQ
      common /b/ ipolar,nnx,nny,nnz,re,pi,r2d,nnxQ,nnyQ,nnzQ,nnzQ1D
      xx = (lon1-lon0)*re/r2d
      yy = (lat1-lat0)*re/r2d
      x1 = (xx-yy*tan(beta))*cos(beta)
      y1 = x1*tan(beta)+yy/cos(beta)
      if (abs(x1) .lt. 0.01) x1 = 0
      if (abs(y1) .lt. 0.01) y1 = 0
      return
      END

      SUBROUTINE xy2lonlat(lon0,lat0,beta,x2,y2,lon2,lat2)
c     Convert x, y to lon, lat
c     lon0, lat0: reference location
c     beta: angle of x axis from east (counterclockwise)
      real lon0,lat0,lon2,lat2,x2,y2,beta
      real xx, yy
c      common/b/ ipolar, nnx, nny, nnz, re, pi, r2d, nnzQ
      common /b/ ipolar,nnx,nny,nnz,re,pi,r2d,nnxQ,nnyQ,nnzQ,nnzQ1D
      yy = (y2-x2*tan(beta))*cos(beta)
      xx = yy*tan(beta)+x2/cos(beta)
      lon2 = xx*r2d/re+lon0
      lat2 = yy*r2d/re+lat0
      return
      END

      REAL FUNCTION piercept(d,z1,z2,v1,v2)
ccccc -- find where ray crosses from 1 isotropic layer to next.
ccccc -- d = horizontal distance between source & receiver
ccccc -- z1, z2 = layer thicknesses (receiver at surface of layer 1)
ccccc -- Uses method of steepest descent.  alpha ~ 20 seems to work well
ccccc -- OUTPUT: distance in horizontal km from source
      real d, z1, z2, v1, v2

      epsilon = 5.e-4   ! dtdr threshold
      alpha = 20.
      u1 = 1./v1        ! slowness of layer 1
      u2 = 1./v2        ! slowness of layer 2
      dr = 0.1          ! needed for dt/dr
      r  = 0.5*d        ! initial guess is halfway between source & receiver
      i = 0

5     t = u2*sqrt(r*r + z2*z2) + u1*sqrt((d-r)**2 + z1*z1)
      dtdr = (u2*sqrt((r+dr)**2 + z2*z2) +
     &           u1*sqrt((d-(r+dr))**2 + z1*z1) - t )/dr

      r = r - alpha*dtdr
      i = i + 1
      if (mod(i,200) .eq. 0) then
        alpha = 0.5*alpha
        go to 5
      endif
      if (abs(dtdr).gt.epsilon .and. i.lt.5000) go to 5
*     write (*,*) i, " steps"

      piercept = r            ! distance in horizontal km from source
      return
      END


subroutine fc3d_clawpack46_set_capacity(mx,my,mz,mbc,dx,dy,dz, &
                                   volume,mcapa,maux,aux)
    implicit none

    integer :: mbc, mx, my, mz, maux, mcapa
    double precision :: dx, dy, dz
    double precision :: aux(1-mbc:mx+mbc,1-mbc:my+mbc,1-mbc:mz+mbc, maux)
    double precision :: volume(-mbc:mx+mbc+1,-mbc:my+mbc+1,-mbc:mz+mbc+1)

    integer :: i,j,k
    double precision :: dxdydz

    dxdydz = dx*dy*dz

    do k = 1-mbc,mz+mbc
        do j = 1-mbc,my+mbc
            do i = 1-mbc,mx+mbc
                aux(i,j,k,mcapa) = volume(i,j,k)/dxdydz
            end do
        end do
    end do
end subroutine fc3d_clawpack46_set_capacity