      subroutine asidgif_geom
     & (
     &  x,shpif0,shpif1,shgif0,shgif1,
     &  qwtif, qwtif0, qwtif1,
     &  ienif0, ienif1
     & )
c
c----------------------------------------
c    aims to compute the geometry related
c    values, such as normal and curvature
c    for DG interface
c----------------------------------------
        use hierarchic_m
        use local_m
        use e3if_geom_m
        use if_global_m
c
        implicit none
c
        real*8, intent(in) :: x(nshg,nsd)
        real*8, dimension(nshl0,nqpt),intent(in)   :: shpif0
        real*8, dimension(nshl1,nqpt),intent(in)   :: shpif1
        real*8, dimension(nsd,nshl0,nqpt), intent(in) :: shgif0
        real*8, dimension(nsd,nshl1,nqpt), intent(in) :: shgif1
        real*8, intent(in) :: qwtif(nqpt), qwtif0(nqpt), qwtif1(nqpt)
        integer, dimension(:,:), pointer, intent(in)   :: ienif0, ienif1
c
      integer :: iel,inode,n
c
        if (ipord .gt. 1) then
          call getsgn(ienif0,sgn0,nshl0,nenl0)
          call getsgn(ienif1,sgn1,nshl1,nenl1)
        endif
c
        call localx(x, xl0,  ienif0, nsd, 'gather  ', nshg, nenl0, npro)
        call localx(x, xl1,  ienif1, nsd, 'gather  ', nshg, nenl1, npro)
c
        call calc_if_normals(xl0,xl1,shpif0,shpif1,shgif0,shgif1,qwtif,qwtif)
c
        call local (if_normal, if_normal_l0, ienif0, nsd, 'scatter ', nshg, nshl0,npro,ipord)
        call local (if_normal, if_normal_l1, ienif1, nsd, 'scatter ', nshg, nshl1,npro,ipord)
c
        if (associated(if_kappa)) then
          call calc_mean_curvature(if_kappa_l0,xl0,ienif0)
          call calc_mean_curvature(if_kappa_l1,xl1,ienif1)
          call local (if_kappa, if_kappa_l0, ienif0, nsd+1, 'scatter ', nshg, nshl0,npro,ipord)
          call local (if_kappa, if_kappa_l1, ienif1, nsd+1, 'scatter ', nshg, nshl1,npro,ipord)
        endif
c
      end subroutine asidgif_geom


      subroutine intrp(aamatr,apr,avgrid,cof,eps100,gmmatr,ipivot,
     $ narxmx,narxt,noutpt,ntprmx,ntprt,nttyo,tempc,tempcs,tmpcmx,
     $ xvec,yvec)
c
c     This subroutine fits interpolating polynomials to data (avgrid)
c     on a temperature grid (tempc). The grid is divided into ranges.
c     A separate polynomial is fitted to the data in each range.
c     Its coefficients are obtained in the cof array. The coefficients
c     for all ranges are returned in the apr array.
c
c     This subroutine is called by:
c
c       EQPT/pcraq.f
c       EQPT/pcrsg.f
c       EQPT/wrpar.f
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c       avgrid = array containing the data on the temperature grid
c
c     Principal output:
c
c       apr    = array of polynomial coefficients (for all ranges)
c       avgrid = array containing the data on the temperature grid
c       narxmx = the maximum number of points or coefficients per
c                  temperature range
c       narxt  = the actual number of points or coefficients per
c                  temperature range
c       nptrmx = the maximum number of temperature ranges
c       nptrt  = the actual number of temperature ranges
c
c     Workspace:
c
c       aamatr = matrix used to calculate the polynomial coefficients
c       cof    = array of fitted polynomial coefficients (for a
c                  single temperature range)
c       xvec   = array of scaled temperatures corresponding to the
c                  data in the yvec array
c       yvec   = array of data to be fitted (for a single temperature
c                  range)
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer narxmx,ntprmx
c
      integer noutpt,nttyo
c
      integer ntprt
c
      integer ipivot(narxmx),narxt(ntprmx)
c
      real*8 apr(narxmx,ntprmx),avgrid(narxmx,ntprmx)
      real*8 tempc(narxmx,ntprmx),tempcs(narxmx,ntprmx),tmpcmx(ntprmx)
      real*8 aamatr(narxmx,narxmx),gmmatr(narxmx,narxmx)
      real*8 cof(narxmx),xvec(narxmx),yvec(narxmx)
c
      real*8 eps100
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer ier,n,nmax,npft,ntpr
c
      real*8 tvecmx
c
c-----------------------------------------------------------------------
c
c     Initialize apr to 0.
c
      nmax = narxmx*ntprmx
      call initaz(apr,nmax)
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Loop on temperature ranges.
c
      do ntpr = 1,ntprt
c
c       Put all real values (9999999. indicates no data) in the yvec
c       array. Put the corresponding scaled temperature values in
c       the xvec array.
c
        npft = 0
c
        do n = 1,narxt(ntpr)
          if (avgrid(n,ntpr) .lt. 9999999.) then
            npft = npft + 1
            xvec(npft) = tempcs(n,ntpr)
            yvec(npft) = avgrid(n,ntpr)
          endif
        enddo
c
c       Here npft is the number of usable values.
c
        if (npft .le. 0) then
c
c         There are no usable values.
c
          apr(1,ntpr) = 9999999.
          go to 110
        endif
c
        if (npft .gt. 1) then
c
c         Check for constant yvec.
c
          do n = 2,npft
            if(abs(yvec(n) -yvec(1)) .gt. eps100) go to 100
          enddo
          npft = 1
  100     continue
        endif
c
        if (npft .le. 1) then
          apr(1,ntpr) = yvec(1)
          go to 110
        endif
c
c       Fit the polynomial.
c
        call polfit(aamatr,cof,gmmatr,ier,ipivot,narxmx,npft,
     $  noutpt,nttyo,xvec,yvec)
c
        if (ier .gt. 0) then
          write (noutpt,1010) ntpr,tempc(1,ntpr),tempc(narxt(ntpr),ntpr)
          write (nttyo,1010) ntpr,tempc(1,ntpr),tempc(narxt(ntpr),ntpr)
 1010     format(/' * Error - (EQPT/intrp) Could not compute the',
     $    /7x,'coefficients of an interpolating polynomial in',
     $    /7x,'temperature range ',i2,' (',f6.2,' - ',f6.2,' C.')
          stop
        endif
c
c       Rescale the coefficients.
c
        tvecmx = tmpcmx(ntpr)
c
c       Calling sequence substitutions:
c         tvecmx for avxmax
c         cof for avy
c         cof for avys
c         npft for nmax
c
        call rscaly(tvecmx,cof,cof,eps100,npft)
c
c       Store the fitted coefficients for this range in the apr array.
c
        do n = 1,npft
          apr(n,ntpr) = cof(n)
        enddo
c
  110   continue
      enddo
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      end


*DECK DEABM
      SUBROUTINE DEABM (F, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID,
     +   RWORK, LRW, IWORK, LIW, RPAR, IPAR)
C***BEGIN PROLOGUE  DEABM
C***PURPOSE  Solve an initial value problem in ordinary differential
C            equations using an Adams-Bashforth method.
C***LIBRARY   SLATEC (DEPAC)
C***CATEGORY  I1A1B
C***TYPE      SINGLE PRECISION (DEABM-S, DDEABM-D)
C***KEYWORDS  ADAMS-BASHFORTH METHOD, DEPAC, INITIAL VALUE PROBLEMS,
C             ODE, ORDINARY DIFFERENTIAL EQUATIONS, PREDICTOR-CORRECTOR
C***AUTHOR  Shampine, L. F., (SNLA)
C           Watts, H. A., (SNLA)
C***DESCRIPTION
C
C   This is the Adams code in the package of differential equation
C   solvers DEPAC, consisting of the codes DERKF, DEABM, and DEBDF.
C   Design of the package was by L. F. Shampine and H. A. Watts.
C   It is documented in
C        SAND79-2374 , DEPAC - Design of a User Oriented Package of ODE
C                              Solvers.
C   DEABM is a driver for a modification of the code ODE written by
C             L. F. Shampine and M. K. Gordon
C             Sandia Laboratories
C             Albuquerque, New Mexico 87185
C
C **********************************************************************
C **             DEPAC PACKAGE OVERVIEW           **
C **************************************************
C
C        You have a choice of three differential equation solvers from
C        DEPAC.  The following brief descriptions are meant to aid you
C        in choosing the most appropriate code for your problem.
C
C        DERKF is a fifth order Runge-Kutta code.  It is the simplest of
C        the three choices, both algorithmically and in the use of the
C        code.  DERKF is primarily designed to solve non-stiff and mild-
C        ly stiff differential equations when derivative evaluations are
C        not expensive.  It should generally not be used to get high
C        accuracy results nor answers at a great many specific points.
C        Because DERKF has very low overhead costs, it will usually
C        result in the least expensive integration when solving
C        problems requiring a modest amount of accuracy and having
C        equations that are not costly to evaluate.  DERKF attempts to
C        discover when it is not suitable for the task posed.
C
C        DEABM is a variable order (one through twelve) Adams code.
C        Its complexity lies somewhere between that of DERKF and DEBDF.
C        DEABM is primarily designed to solve non-stiff and mildly stiff
C        differential equations when derivative evaluations are
C        expensive, high accuracy results are needed or answers at
C        many specific points are required.  DEABM attempts to discover
C        when it is not suitable for the task posed.
C
C        DEBDF is a variable order (one through five) backward
C        differentiation formula code.  It is the most complicated of
C        the three choices.  DEBDF is primarily designed to solve stiff
C        differential equations at crude to moderate tolerances.
C        If the problem is very stiff at all, DERKF and DEABM will be
C        quite inefficient compared to DEBDF.  However, DEBDF will be
C        inefficient compared to DERKF and DEABM on non-stiff problems
C        because it uses much more storage, has a much larger overhead,
C        and the low order formulas will not give high accuracies
C        efficiently.
C
C        The concept of stiffness cannot be described in a few words.
C        If you do not know the problem to be stiff, try either DERKF
C        or DEABM.  Both of these codes will inform you of stiffness
C        when the cost of solving such problems becomes important.
C
C **********************************************************************
C ** ABSTRACT **
C **************
C
C   Subroutine DEABM uses the Adams-Bashforth-Moulton predictor-
C   corrector formulas of orders one through twelve to integrate a
C   system of NEQ first order ordinary differential equations of the
C   form
C                         DU/DX = F(X,U)
C   when the vector Y(*) of initial values for U(*) at X=T is given. The
C   subroutine integrates from T to TOUT.  It is easy to continue the
C   integration to get results at additional TOUT.  This is the interval
C   mode of operation.  It is also easy for the routine to return with
C   the solution at each intermediate step on the way to TOUT.  This is
C   the intermediate-output mode of operation.
C
C   DEABM uses subprograms DES, STEPS, SINTRP, HSTART, HVNRM, R1MACH and
C   the error handling routine XERMSG.  The only machine dependent
C   parameters to be assigned appear in R1MACH.
C
C **********************************************************************
C ** DESCRIPTION OF THE ARGUMENTS TO DEABM (AN OVERVIEW) **
C *********************************************************
C
C   The parameters are
C
C      F -- This is the name of a subroutine which you provide to
C             define the differential equations.
C
C      NEQ -- This is the number of (first order) differential
C             equations to be integrated.
C
C      T -- This is a value of the independent variable.
C
C      Y(*) -- This array contains the solution components at T.
C
C      TOUT -- This is a point at which a solution is desired.
C
C      INFO(*) -- The basic task of the code is to integrate the
C             differential equations from T to TOUT and return an
C             answer at TOUT.  INFO(*) is an integer array which is used
C             to communicate exactly how you want this task to be
C             carried out.
C
C      RTOL, ATOL -- These quantities represent relative and absolute
C             error tolerances which you provide to indicate how
C             accurately you wish the solution to be computed.  You may
C             choose them to be both scalars or else both vectors.
C
C      IDID -- This scalar quantity is an indicator reporting what
C             the code did.  You must monitor this integer variable to
C             decide what action to take next.
C
C      RWORK(*), LRW -- RWORK(*) is a real work array of length LRW
C             which provides the code with needed storage space.
C
C      IWORK(*), LIW -- IWORK(*) is an integer work array of length LIW
C             which provides the code with needed storage space and an
C             across call flag.
C
C      RPAR, IPAR -- These are real and integer parameter arrays which
C             you can use for communication between your calling
C             program and the F subroutine.
C
C  Quantities which are used as input items are
C             NEQ, T, Y(*), TOUT, INFO(*),
C             RTOL, ATOL, RWORK(1), LRW and LIW.
C
C  Quantities which may be altered by the code are
C             T, Y(*), INFO(1), RTOL, ATOL,
C             IDID, RWORK(*) and IWORK(*).
C
C **********************************************************************
C ** INPUT -- WHAT TO DO ON THE FIRST CALL TO DEABM **
C ****************************************************
C
C   The first call of the code is defined to be the start of each new
C   problem.  Read through the descriptions of all the following items,
C   provide sufficient storage space for designated arrays, set
C   appropriate variables for the initialization of the problem, and
C   give information about how you want the problem to be solved.
C
C
C      F -- Provide a subroutine of the form
C                               F(X,U,UPRIME,RPAR,IPAR)
C             to define the system of first order differential equations
C             which is to be solved.  For the given values of X and the
C             vector  U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must
C             evaluate the NEQ components of the system of differential
C             equations  DU/DX = F(X,U)  and store the derivatives in
C             array UPRIME(*), that is,  UPRIME(I) = * DU(I)/DX *  for
C             equations I=1,...,NEQ.
C
C             Subroutine F must not alter X or U(*).  You must declare
C             the name F in an external statement in your program that
C             calls DEABM.  You must dimension U and UPRIME in F.
C
C             RPAR and IPAR are real and integer parameter arrays which
C             you can use for communication between your calling program
C             and subroutine F.  They are not used or altered by DEABM.
C             If you do not need RPAR or IPAR, ignore these parameters
C             by treating them as dummy arguments.  If you do choose to
C             use them, dimension them in your calling program and in F
C             as arrays of appropriate length.
C
C      NEQ -- Set it to the number of differential equations.
C             (NEQ .GE. 1)
C
C      T -- Set it to the initial point of the integration.
C             You must use a program variable for T because the code
C             changes its value.
C
C      Y(*) -- Set this vector to the initial values of the NEQ solution
C             components at the initial point.  You must dimension Y at
C             least NEQ in your calling program.
C
C      TOUT -- Set it to the first point at which a solution
C             is desired.  You can take TOUT = T, in which case the code
C             will evaluate the derivative of the solution at T and
C             return.  Integration either forward in T  (TOUT .GT.  T)
C             or backward in T  (TOUT .LT.  T)  is permitted.
C
C             The code advances the solution from T to TOUT using
C             step sizes which are automatically selected so as to
C             achieve the desired accuracy.  If you wish, the code will
C             return with the solution and its derivative following
C             each intermediate step (intermediate-output mode) so that
C             you can monitor them, but you still must provide TOUT in
C             accord with the basic aim of the code.
C
C             The first step taken by the code is a critical one
C             because it must reflect how fast the solution changes near
C             the initial point.  The code automatically selects an
C             initial step size which is practically always suitable for
C             the problem.  By using the fact that the code will not
C             step past TOUT in the first step, you could, if necessary,
C             restrict the length of the initial step size.
C
C             For some problems it may not be permissible to integrate
C             past a point TSTOP because a discontinuity occurs there
C             or the solution or its derivative is not defined beyond
C             TSTOP.  When you have declared a TSTOP point (see INFO(4)
C             and RWORK(1)), you have told the code not to integrate
C             past TSTOP.  In this case any TOUT beyond TSTOP is invalid
C             input.
C
C      INFO(*) -- Use the INFO array to give the code more details about
C             how you want your problem solved.  This array should be
C             dimensioned of length 15 to accommodate other members of
C             DEPAC or possible future extensions, though DEABM uses
C             only the first four entries.  You must respond to all of
C             the following items which are arranged as questions.  The
C             simplest use of the code corresponds to answering all
C             questions as YES ,i.e. setting all entries of INFO to 0.
C
C        INFO(1) -- This parameter enables the code to initialize
C             itself.  You must set it to indicate the start of every
C             new problem.
C
C            **** Is this the first call for this problem ...
C                  YES -- Set INFO(1) = 0
C                   NO -- Not applicable here.
C                         See below for continuation calls.  ****
C
C        INFO(2) -- How much accuracy you want of your solution
C               is specified by the error tolerances RTOL and ATOL.
C               The simplest use is to take them both to be scalars.
C               To obtain more flexibility, they can both be vectors.
C               The code must be told your choice.
C
C            **** Are both error tolerances RTOL, ATOL scalars ...
C                  YES -- Set INFO(2) = 0
C                         and input scalars for both RTOL and ATOL
C                   NO -- Set INFO(2) = 1
C                         and input arrays for both RTOL and ATOL ****
C
C        INFO(3) -- The code integrates from T in the direction
C               of TOUT by steps.  If you wish, it will return the
C               computed solution and derivative at the next
C               intermediate step (the intermediate-output mode) or
C               TOUT, whichever comes first.  This is a good way to
C               proceed if you want to see the behavior of the solution.
C               If you must have solutions at a great many specific
C               TOUT points, this code will compute them efficiently.
C
C            **** Do you want the solution only at
C                 TOUT (and not at the next intermediate step) ...
C                  YES -- Set INFO(3) = 0
C                   NO -- Set INFO(3) = 1 ****
C
C        INFO(4) -- To handle solutions at a great many specific
C               values TOUT efficiently, this code may integrate past
C               TOUT and interpolate to obtain the result at TOUT.
C               Sometimes it is not possible to integrate beyond some
C               point TSTOP because the equation changes there or it is
C               not defined past TSTOP.  Then you must tell the code
C               not to go past.
C
C            **** Can the integration be carried out without any
C                 restrictions on the independent variable T ...
C                  YES -- Set INFO(4)=0
C                   NO -- Set INFO(4)=1
C                         and define the stopping point TSTOP by
C                         setting RWORK(1)=TSTOP ****
C
C      RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL)
C             error tolerances to tell the code how accurately you want
C             the solution to be computed.  They must be defined as
C             program variables because the code may change them.  You
C             have two choices --
C                  both RTOL and ATOL are scalars. (INFO(2)=0)
C                  both RTOL and ATOL are vectors. (INFO(2)=1)
C             In either case all components must be non-negative.
C
C             The tolerances are used by the code in a local error test
C             at each step which requires roughly that
C                     ABS(LOCAL ERROR) .LE. RTOL*ABS(Y)+ATOL
C             for each vector component.
C             (More specifically, a Euclidean norm is used to measure
C             the size of vectors, and the error test uses the magnitude
C             of the solution at the beginning of the step.)
C
C             The true (global) error is the difference between the true
C             solution of the initial value problem and the computed
C             approximation.  Practically all present day codes,
C             including this one, control the local error at each step
C             and do not even attempt to control the global error
C             directly.  Roughly speaking, they produce a solution Y(T)
C             which satisfies the differential equations with a
C             residual R(T),    DY(T)/DT = F(T,Y(T)) + R(T)   ,
C             and, almost always, R(T) is bounded by the error
C             tolerances.  Usually, but not always, the true accuracy of
C             the computed Y is comparable to the error tolerances. This
C             code will usually, but not always, deliver a more accurate
C             solution if you reduce the tolerances and integrate again.
C             By comparing two such solutions you can get a fairly
C             reliable idea of the true error in the solution at the
C             bigger tolerances.
C
C             Setting ATOL=0.0 results in a pure relative error test on
C             that component.  Setting RTOL=0.0 results in a pure abso-
C             lute error test on that component.  A mixed test with non-
C             zero RTOL and ATOL corresponds roughly to a relative error
C             test when the solution component is much bigger than ATOL
C             and to an absolute error test when the solution component
C             is smaller than the threshold ATOL.
C
C             Proper selection of the absolute error control parameters
C             ATOL  requires you to have some idea of the scale of the
C             solution components.  To acquire this information may mean
C             that you will have to solve the problem more than once.
C             In the absence of scale information, you should ask for
C             some relative accuracy in all the components (by setting
C             RTOL values non-zero) and perhaps impose extremely small
C             absolute error tolerances to protect against the danger of
C             a solution component becoming zero.
C
C             The code will not attempt to compute a solution at an
C             accuracy unreasonable for the machine being used.  It will
C             advise you if you ask for too much accuracy and inform
C             you as to the maximum accuracy it believes possible.
C
C      RWORK(*) -- Dimension this real work array of length LRW in your
C             calling program.
C
C      RWORK(1) -- If you have set INFO(4)=0, you can ignore this
C             optional input parameter.  Otherwise you must define a
C             stopping point TSTOP by setting   RWORK(1) = TSTOP.
C             (for some problems it may not be permissible to integrate
C             past a point TSTOP because a discontinuity occurs there
C             or the solution or its derivative is not defined beyond
C             TSTOP.)
C
C      LRW -- Set it to the declared length of the RWORK array.
C             You must have  LRW .GE. 130+21*NEQ
C
C      IWORK(*) -- Dimension this integer work array of length LIW in
C             your calling program.
C
C      LIW -- Set it to the declared length of the IWORK array.
C             You must have  LIW .GE. 51
C
C      RPAR, IPAR -- These are parameter arrays, of real and integer
C             type, respectively.  You can use them for communication
C             between your program that calls DEABM and the  F
C             subroutine.  They are not used or altered by DEABM.  If
C             you do not need RPAR or IPAR, ignore these parameters by
C             treating them as dummy arguments.  If you do choose to use
C             them, dimension them in your calling program and in F as
C             arrays of appropriate length.
C
C **********************************************************************
C ** OUTPUT -- AFTER ANY RETURN FROM DEABM **
C *******************************************
C
C   The principal aim of the code is to return a computed solution at
C   TOUT, although it is also possible to obtain intermediate results
C   along the way.  To find out whether the code achieved its goal
C   or if the integration process was interrupted before the task was
C   completed, you must check the IDID parameter.
C
C
C      T -- The solution was successfully advanced to the
C             output value of T.
C
C      Y(*) -- Contains the computed solution approximation at T.
C             You may also be interested in the approximate derivative
C             of the solution at T.  It is contained in
C             RWORK(21),...,RWORK(20+NEQ).
C
C      IDID -- Reports what the code did
C
C                         *** Task Completed ***
C                   reported by positive values of IDID
C
C             IDID = 1 -- A step was successfully taken in the
C                       intermediate-output mode.  The code has not
C                       yet reached TOUT.
C
C             IDID = 2 -- The integration to TOUT was successfully
C                       completed (T=TOUT) by stepping exactly to TOUT.
C
C             IDID = 3 -- The integration to TOUT was successfully
C                       completed (T=TOUT) by stepping past TOUT.
C                       Y(*) is obtained by interpolation.
C
C                         *** Task Interrupted ***
C                   reported by negative values of IDID
C
C             IDID = -1 -- A large amount of work has been expended.
C                       (500 steps attempted)
C
C             IDID = -2 -- The error tolerances are too stringent.
C
C             IDID = -3 -- The local error test cannot be satisfied
C                       because you specified a zero component in ATOL
C                       and the corresponding computed solution
C                       component is zero.  Thus, a pure relative error
C                       test is impossible for this component.
C
C             IDID = -4 -- The problem appears to be stiff.
C
C             IDID = -5,-6,-7,..,-32  -- Not applicable for this code
C                       but used by other members of DEPAC or possible
C                       future extensions.
C
C                         *** Task Terminated ***
C                   reported by the value of IDID=-33
C
C             IDID = -33 -- The code has encountered trouble from which
C                       it cannot recover.  A message is printed
C                       explaining the trouble and control is returned
C                       to the calling program.  For example, this
C                       occurs when invalid input is detected.
C
C      RTOL, ATOL -- These quantities remain unchanged except when
C             IDID = -2.  In this case, the error tolerances have been
C             increased by the code to values which are estimated to be
C             appropriate for continuing the integration.  However, the
C             reported solution at T was obtained using the input values
C             of RTOL and ATOL.
C
C      RWORK, IWORK -- Contain information which is usually of no
C             interest to the user but necessary for subsequent calls.
C             However, you may find use for
C
C             RWORK(11)--Which contains the step size H to be
C                        attempted on the next step.
C
C             RWORK(12)--If the tolerances have been increased by the
C                        code (IDID = -2) , they were multiplied by the
C                        value in RWORK(12).
C
C             RWORK(13)--Which contains the current value of the
C                        independent variable, i.e.  the farthest point
C                        integration has reached.  This will be dif-
C                        ferent from T only when interpolation has been
C                        performed (IDID=3).
C
C             RWORK(20+I)--Which contains the approximate derivative of
C                        the solution component Y(I).  In DEABM, it is
C                        obtained by calling subroutine F to evaluate
C                        the differential equation using T and Y(*) when
C                        IDID=1 or 2, and by interpolation when IDID=3.
C
C **********************************************************************
C ** INPUT -- WHAT TO DO TO CONTINUE THE INTEGRATION **
C **             (CALLS AFTER THE FIRST)             **
C *****************************************************
C
C        This code is organized so that subsequent calls to continue the
C        integration involve little (if any) additional effort on your
C        part.  You must monitor the IDID parameter in order to
C        determine what to do next.
C
C        Recalling that the principal task of the code is to integrate
C        from T to TOUT (the interval mode), usually all you will need
C        to do is specify a new TOUT upon reaching the current TOUT.
C
C        Do not alter any quantity not specifically permitted below,
C        in particular do not alter NEQ, T, Y(*), RWORK(*), IWORK(*) or
C        the differential equation in subroutine F.  Any such alteration
C        constitutes a new problem and must be treated as such, i.e.
C        you must start afresh.
C
C        You cannot change from vector to scalar error control or vice
C        versa (INFO(2)) but you can change the size of the entries of
C        RTOL, ATOL.  Increasing a tolerance makes the equation easier
C        to integrate.  Decreasing a tolerance will make the equation
C        harder to integrate and should generally be avoided.
C
C        You can switch from the intermediate-output mode to the
C        interval mode (INFO(3)) or vice versa at any time.
C
C        If it has been necessary to prevent the integration from going
C        past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the
C        code will not integrate to any TOUT beyond the currently
C        specified TSTOP.  Once TSTOP has been reached you must change
C        the value of TSTOP or set INFO(4)=0.  You may change INFO(4)
C        or TSTOP at any time but you must supply the value of TSTOP in
C        RWORK(1) whenever you set INFO(4)=1.
C
C        The parameter INFO(1) is used by the code to indicate the
C        beginning of a new problem and to indicate whether integration
C        is to be continued.  You must input the value  INFO(1) = 0
C        when starting a new problem.  You must input the value
C        INFO(1) = 1  if you wish to continue after an interrupted task.
C        Do not set  INFO(1) = 0  on a continuation call unless you
C        want the code to restart at the current T.
C
C                         *** Following a Completed Task ***
C         If
C             IDID = 1, call the code again to continue the integration
C                     another step in the direction of TOUT.
C
C             IDID = 2 or 3, define a new TOUT and call the code again.
C                     TOUT must be different from T.  You cannot change
C                     the direction of integration without restarting.
C
C                         *** Following an Interrupted Task ***
C                     To show the code that you realize the task was
C                     interrupted and that you want to continue, you
C                     must take appropriate action and reset INFO(1) = 1
C         If
C             IDID = -1, the code has attempted 500 steps.
C                     If you want to continue, set INFO(1) = 1 and
C                     call the code again.  An additional 500 steps
C                     will be allowed.
C
C             IDID = -2, the error tolerances RTOL, ATOL have been
C                     increased to values the code estimates appropriate
C                     for continuing.  You may want to change them
C                     yourself.  If you are sure you want to continue
C                     with relaxed error tolerances, set INFO(1)=1 and
C                     call the code again.
C
C             IDID = -3, a solution component is zero and you set the
C                     corresponding component of ATOL to zero.  If you
C                     are sure you want to continue, you must first
C                     alter the error criterion to use positive values
C                     for those components of ATOL corresponding to zero
C                     solution components, then set INFO(1)=1 and call
C                     the code again.
C
C             IDID = -4, the problem appears to be stiff.  It is very
C                     inefficient to solve such problems with DEABM. The
C                     code DEBDF in DEPAC handles this task efficiently.
C                     If you are absolutely sure you want to continue
C                     with DEABM, set INFO(1)=1 and call the code again.
C
C             IDID = -5,-6,-7,..,-32  --- cannot occur with this code
C                     but used by other members of DEPAC or possible
C                     future extensions.
C
C                         *** Following a Terminated Task ***
C         If
C             IDID = -33, you cannot continue the solution of this
C                     problem.  An attempt to do so will result in your
C                     run being terminated.
C
C **********************************************************************
C
C***REFERENCES  L. F. Shampine and H. A. Watts, DEPAC - design of a user
C                 oriented package of ODE solvers, Report SAND79-2374,
C                 Sandia Laboratories, 1979.
C***ROUTINES CALLED  DES, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800501  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   891024  Changed references from VNORM to HVNRM.  (WRB)
C   891024  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900510  Convert XERRWV calls to XERMSG calls.  (RWC)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DEABM
C
      LOGICAL START,PHASE1,NORND,STIFF,INTOUT
C
      DIMENSION Y(*),INFO(15),RTOL(*),ATOL(*),RWORK(*),IWORK(*),
     1          RPAR(*),IPAR(*)
C
      CHARACTER*8 XERN1
      CHARACTER*16 XERN3
C
      EXTERNAL F
C
C     CHECK FOR AN APPARENT INFINITE LOOP
C
C***FIRST EXECUTABLE STATEMENT  DEABM
      IF ( INFO(1) .EQ. 0 ) IWORK(LIW) = 0
      IF (IWORK(LIW) .GE. 5) THEN
         IF (T .EQ. RWORK(21 + NEQ)) THEN
            WRITE (XERN3, '(1PE15.6)') T
            CALL XERMSG ('SLATEC', 'DEABM',
     *         'AN APPARENT INFINITE LOOP HAS BEEN DETECTED.$$' //
     *         'YOU HAVE MADE REPEATED CALLS AT T = ' // XERN3 //
     *         ' AND THE INTEGRATION HAS NOT ADVANCED.  CHECK THE ' //
     *         'WAY YOU HAVE SET PARAMETERS FOR THE CALL TO THE ' //
     *         'CODE, PARTICULARLY INFO(1).',  13, 2)
            RETURN
         ENDIF
      ENDIF
C
C     CHECK LRW AND LIW FOR SUFFICIENT STORAGE ALLOCATION
C
      IDID=0
      IF (LRW .LT. 130+21*NEQ) THEN
         WRITE (XERN1, '(I8)') LRW
         CALL XERMSG ('SLATEC', 'DEABM', 'THE LENGTH OF THE RWORK ' //
     *      'ARRAY MUST BE AT LEAST 130 + 21*NEQ.$$' //
     *      'YOU HAVE CALLED THE CODE WITH LRW = ' // XERN1, 1, 1)
         IDID=-33
      ENDIF
C
      IF (LIW .LT. 51) THEN
         WRITE (XERN1, '(I8)') LIW
         CALL XERMSG ('SLATEC', 'DEABM', 'THE LENGTH OF THE IWORK ' //
     *      'ARRAY MUST BE AT LEAST 51.$$YOU HAVE CALLED THE CODE ' //
     *      'WITH LIW = ' // XERN1, 2, 1)
         IDID=-33
      ENDIF
C
C     COMPUTE THE INDICES FOR THE ARRAYS TO BE STORED IN THE WORK ARRAY
C
      IYPOUT = 21
      ITSTAR = NEQ + 21
      IYP = 1 + ITSTAR
      IYY = NEQ + IYP
      IWT = NEQ + IYY
      IP = NEQ + IWT
      IPHI = NEQ + IP
      IALPHA = (NEQ*16) + IPHI
      IBETA = 12 + IALPHA
      IPSI = 12 + IBETA
      IV = 12 + IPSI
      IW = 12 + IV
      ISIG = 12 + IW
      IG = 13 + ISIG
      IGI = 13 + IG
      IXOLD = 11 + IGI
      IHOLD = 1 + IXOLD
      ITOLD = 1 + IHOLD
      IDELSN = 1 + ITOLD
      ITWOU = 1 + IDELSN
      IFOURU = 1 + ITWOU
C
      RWORK(ITSTAR) = T
      IF (INFO(1) .EQ. 0) GO TO 50
      START = IWORK(21) .NE. (-1)
      PHASE1 = IWORK(22) .NE. (-1)
      NORND = IWORK(23) .NE. (-1)
      STIFF = IWORK(24) .NE. (-1)
      INTOUT = IWORK(25) .NE. (-1)
C
 50   CALL DES(F,NEQ,T,Y,TOUT,INFO,RTOL,ATOL,IDID,RWORK(IYPOUT),
     1         RWORK(IYP),RWORK(IYY),RWORK(IWT),RWORK(IP),RWORK(IPHI),
     2         RWORK(IALPHA),RWORK(IBETA),RWORK(IPSI),RWORK(IV),
     3         RWORK(IW),RWORK(ISIG),RWORK(IG),RWORK(IGI),RWORK(11),
     4         RWORK(12),RWORK(13),RWORK(IXOLD),RWORK(IHOLD),
     5         RWORK(ITOLD),RWORK(IDELSN),RWORK(1),RWORK(ITWOU),
     5         RWORK(IFOURU),START,PHASE1,NORND,STIFF,INTOUT,IWORK(26),
     6         IWORK(27),IWORK(28),IWORK(29),IWORK(30),IWORK(31),
     7         IWORK(32),IWORK(33),IWORK(34),IWORK(35),IWORK(45),
     8         RPAR,IPAR)
C
      IWORK(21) = -1
      IF (START) IWORK(21) = 1
      IWORK(22) = -1
      IF (PHASE1) IWORK(22) = 1
      IWORK(23) = -1
      IF (NORND) IWORK(23) = 1
      IWORK(24) = -1
      IF (STIFF) IWORK(24) = 1
      IWORK(25) = -1
      IF (INTOUT) IWORK(25) = 1
C
      IF (IDID .NE. (-2)) IWORK(LIW) = IWORK(LIW) + 1
      IF (T .NE. RWORK(ITSTAR)) IWORK(LIW) = 0
C
      RETURN
      END


C++***************************************************************
C Program to compute FFT2
C Calling FFT_2D (in "fft_nag.for", "fft_fourn.for" or fftw_set.c)
C WARNING: NAG FFT divides the result by SQRT(NX*NY)
C
C JLP
C Version of 08-10-2008
C--***************************************************************
        PROGRAM FFT2
        IMPLICIT NONE
C For 32-bit computers, PNTR should be declared as integer*4:
C        INTEGER*4 PNTR_RE,PNTR_IM
C For 64-bit computers, PNTR should be declared as integer*8:
        INTEGER*8 PNTR_RE,PNTR_IM
        INTEGER*4 KOD,IOPT,NX,NY,NX1,NY1,MADRID(1)
        CHARACTER NAME*60,COMMENTS*80,ANS*1
        COMMON /VMR/MADRID

        CALL JLP_BEGIN

C Inquire the format (input/output) :
        CALL JLP_INQUIFMT

C Option:
        PRINT *,'FFTW CONVENTION WITH +2 i PI for direct FFT...'
        WRITE(6,15)
15        FORMAT('FFT2, Version 08/10/2008',/,' Options: ',/,
     1        ' 1=direct FFT (in/out: real,imaginary)',/,
     1        ' 2=direct FFT (in: real,ima /out: modsq,phase)',/,
     1        ' 3=direct FFT (in: real,ima /out: mod,phase)',/,
     1        ' -1=inverse FFT (in/out: real,imaginary)',/,
     1        ' -2=inverse FFT (in: modsq,phase /out: real,ima)',/,
     1        ' -3=inverse FFT (in: mod,phase /out: real,ima)',/,
     1        ' Enter your choice:')
        READ(5,*) IOPT
        IF((IOPT.EQ.0).OR.(IOPT.LT.-3)
     1     .OR.(IOPT.GT.3))THEN
           WRITE(6,17)
17           FORMAT(' Exit: bad option')
        ENDIF

C Input :
        IF(IOPT.EQ.-3)THEN
          WRITE(6,*)' Input image (modulus):'
        ELSE IF(IOPT.EQ.-2)THEN
          WRITE(6,*)' Input image (power spectrum):'
        ELSE
          WRITE(6,*)' Input image (real part):'
        ENDIF
        READ(5,10) NAME
        CALL JLP_VM_READIMAG(PNTR_RE,NX,NY,NAME,COMMENTS)

C Imaginary part:
          IF((IOPT.EQ.1).OR.(IOPT.EQ.-1))THEN
            WRITE(6,22)
22          FORMAT(' Input image (imaginary part):',/,
     1        ' Null imaginary part? (N) ?')
          ELSE
            WRITE(6,23)
23          FORMAT(' Input image (phase):',/,
     1        ' Null phase? (N) ?')
          ENDIF
C
          READ(5,10) ANS
10          FORMAT(A)

        IF(ANS.NE.'Y'.AND.ANS.NE.'y')THEN
          WRITE(6,*)' Enter filename: '
          READ(5,10) NAME
          CALL JLP_VM_READIMAG(PNTR_IM,NX1,NY1,NAME,COMMENTS)
C Check the size:
          IF((NX1.NE.NX).OR.(NY1.NE.NY))THEN
            WRITE(6,21)
21           FORMAT(' FATAL ERROR: Wrong size for the input images',/,
     1        ' (should be the same for the real/imaginary parts)')
            GOTO 999
          ENDIF
        ELSE
          CALL JLP_GETVM(PNTR_IM,NX*NY*4)
          CALL ZERO2(MADRID(PNTR_IM),NX,NY,NX)
        ENDIF

        IF(IOPT.EQ.-2)THEN
          CALL MODSQ_PHASE_TO_RE_IM(MADRID(PNTR_RE),MADRID(PNTR_IM),
     1                              NX,NY,NX)
        ELSE IF(IOPT.EQ.-3)THEN
          CALL MOD_PHASE_TO_RE_IM(MADRID(PNTR_RE),MADRID(PNTR_IM),
     1                            NX,NY,NX)
        ENDIF

C JLP 2008: I shift the images to 0,0, to avoid discontinuities
C (since I assume that the initial image is centered on the frame
C whereas the Fourier transform works with zero frequency at 0,0)
        CALL RECENT_FFT(MADRID(PNTR_RE),MADRID(PNTR_RE),NX,NY,NX)
        CALL RECENT_FFT(MADRID(PNTR_IM),MADRID(PNTR_IM),NX,NY,NX)

C FFT direct FFT corresponds to KOD=1:
C WARNING:
C JLP 2008: for FFTW I use the convention of +2 i PI for direct transform
C and - 2 i PI for inverse transform (as in vcrb.exe for PISCO data)
        IF(IOPT.GT.0)THEN
          KOD=1
        ELSE
          KOD=-1
        ENDIF
C****************************************************************
C Can use NAG library (with FFT_2D in 'fft_nag.for')
C or a routine derived from Numerical Recipees in 'fft_fourn.for'
C       CALL FFT_2D_FOURN(MADRID(PNTR_RE),MADRID(PNTR_IM),NX,NY,NX,KOD)
C Now in "FFTW" in "fftw_set.c"
        CALL FFTW_2D_FLT(MADRID(PNTR_RE),MADRID(PNTR_IM),NX,NY,NX,KOD)

C Check the value of IOPT:
        IF(IOPT.EQ.2)THEN
          CALL RE_IM_TO_MODSQ_PHASE(MADRID(PNTR_RE),MADRID(PNTR_IM),
     1                              NX,NY,NX)
        ELSE IF(IOPT.EQ.3)THEN
          CALL RE_IM_TO_MOD_PHASE(MADRID(PNTR_RE),MADRID(PNTR_IM),
     1                            NX,NY,NX)
        ENDIF

C Output :
        WRITE(6,*)' Real part / modsq or modulus:'
        READ(5,10) NAME
C Always recenter the output: if it is in direct space a null phase
C would break up the object in two upon the bottom and upper edges.
        CALL RECENT_FFT(MADRID(PNTR_RE),MADRID(PNTR_RE),NX,NY,NX)
        CALL JLP_WRITEIMAG(MADRID(PNTR_RE),NX,NY,NX,NAME,COMMENTS)

        WRITE(6,*)' Imaginary part / Phase:'
        READ(5,10) NAME
        CALL RECENT_FFT(MADRID(PNTR_IM),MADRID(PNTR_IM),NX,NY,NX)
        CALL JLP_WRITEIMAG(MADRID(PNTR_IM),NX,NY,NX,NAME,COMMENTS)

999        CALL JLP_END
        STOP
        END
C****************************************************************
C Compute power spectrum and phase from real and imaginary parts
C****************************************************************
        SUBROUTINE RE_IM_TO_MODSQ_PHASE(TR,TI,NX,NY,IDIM)
        INTEGER NX,NY,I,J,IDIM
        REAL TR(IDIM,*),TI(IDIM,*)
         DO 60 J=1,NY
          DO 60 I=1,NX
            AR=TR(I,J)
            AI=TI(I,J)
            TR(I,J)=AR*AR+AI*AI
            CALL PHASE_FROM_RE_IM(AR,AI,TI(I,J))
60        CONTINUE
        RETURN
        END
C****************************************************************
C Compute real and imaginary parts from power spectrum and phase
C****************************************************************
        SUBROUTINE MODSQ_PHASE_TO_RE_IM(TR,TI,NX,NY,IDIM)
        INTEGER NX,NY,I,J,IDIM
        REAL TR(IDIM,*),TI(IDIM,*)
        REAL AR,AI
         DO 60 J=1,NY
          DO 60 I=1,NX
            AR=TR(I,J)
            IF(AR.GT.0.)THEN
              AR=SQRT(AR)
            ELSE
              AR=0.
            ENDIF
            AI=TI(I,J)
            TR(I,J)=AR*COS(AI)
            TI(I,J)=AR*SIN(AI)
60        CONTINUE
        RETURN
        END
C****************************************************************
C Compute modulus and phase from real and imaginary parts
C****************************************************************
        SUBROUTINE RE_IM_TO_MOD_PHASE(TR,TI,NX,NY,IDIM)
        IMPLICIT NONE
        INTEGER NX,NY,I,J,IDIM
        REAL TR(IDIM,*),TI(IDIM,*),AR,AI
         DO 60 J=1,NY
          DO 60 I=1,NX
            AR=TR(I,J)
            AI=TI(I,J)
            TR(I,J)=SQRT(AR*AR+AI*AI)
            CALL PHASE_FROM_RE_IM(AR, AI, TI(I,J))
60        CONTINUE
        RETURN
        END
C****************************************************************
C Compute real and imaginary parts from modulus and phase
C****************************************************************
        SUBROUTINE MOD_PHASE_TO_RE_IM(TR,TI,NX,NY,IDIM)
        INTEGER NX,NY,I,J,IDIM
        REAL TR(IDIM,*),TI(IDIM,*)
        REAL AR,AI
         DO 60 J=1,NY
          DO 60 I=1,NX
            AR=TR(I,J)
            AI=TI(I,J)
            TR(I,J)=AR*COS(AI)
            TI(I,J)=AR*SIN(AI)
60        CONTINUE
        RETURN
        END
C****************************************************************
        SUBROUTINE ZERO2(ARRAY,NX,NY,IDIM)
        INTEGER NX,NY,I,J,IDIM
        REAL ARRAY(IDIM,*)
        DO J=1,NY
         DO I=1,NX
           ARRAY(I,J)=0.
          ENDDO
        ENDDO
        RETURN
        END
C**********************************************************************
C Compute the phase (in the range [0, 2PI]) from real and imaginary part
C*********************************************************************
        SUBROUTINE PHASE_FROM_RE_IM(AR, AI, PHASE)
        IMPLICIT NONE
        REAL AI, AR, PI, EPSILON, PHASE
        PI=3.14159
C JLP2008: round off errors are around 1.e-9:
        EPSILON = 1.E-9
          IF(ABS(AR).LE.EPSILON) AR = 0.
          IF(ABS(AI).LE.EPSILON) AI = 0.
          IF(AR.NE.0.) THEN
             PHASE=ATAN(AI/AR)
             IF(AR.LT.0.)PHASE=PHASE+PI
          ELSE
             IF(AI.EQ.0.)THEN
               PHASE=0.
             ELSE IF(AI.GT.0.)THEN
               PHASE=PI/2.
             ELSE
               PHASE=3.*PI/2.
             ENDIF
          ENDIF
          IF(PHASE.LT.0.)PHASE=PHASE+2.*PI
         RETURN
         END


! File %M% from Library %Q%
! Version %I% from %G% extracted: %H%
!------------------------------------------------------------------------------

MODULE flake

!------------------------------------------------------------------------------
!
! Description:
!
!  The main program unit of the lake model FLake,
!  containing most of the FLake procedures.
!  Most FLake variables and local parameters are declared.
!
!  FLake (Fresh-water Lake) is a lake model capable of predicting the surface temperature
!  in lakes of various depth on the time scales from a few hours to a year.
!  The model is based on a two-layer parametric representation of
!  the evolving temperature profile, where the structure of the stratified layer between the
!  upper mixed layer and the basin bottom, the lake thermocline,
!  is described using the concept of self-similarity of the temperature-depth curve.
!  The concept was put forward by Kitaigorodskii and Miropolsky (1970)
!  to describe the vertical temperature structure of the oceanic seasonal thermocline.
!  It has since been successfully used in geophysical applications.
!  The concept of self-similarity of the evolving temperature profile
!  is also used to describe the vertical structure of the thermally active upper layer
!  of bottom sediments and of the ice and snow cover.
!
!  The lake model incorporates the heat budget equations
!  for the four layers in question, viz., snow, ice, water and bottom sediments,
!  developed with due regard for the vertically distributed character
!  of solar radiation heating.
!  The entrainment equation that incorporates the Zilitinkevich (1975) spin-up term
!  is used to compute the depth of a convectively-mixed layer.
!  A relaxation-type equation is used
!  to compute the wind-mixed layer depth in stable and neutral stratification,
!  where a multi-limit formulation for the equilibrium mixed-layer depth
!  proposed by Zilitinkevich and Mironov (1996)
!  accounts for the effects of the earth's rotation, of the surface buoyancy flux
!  and of the static stability in the thermocline.
!  The equations for the mixed-layer depth are developed with due regard for
!  the volumetric character of the radiation heating.
!  Simple thermodynamic arguments are invoked to develop
!  the evolution equations for the ice thickness and for the snow thickness.
!  The heat flux through the water-bottom sediment interface is computed,
!  using a parameterization proposed by Golosov et al. (1998).
!  The heat flux trough the air-water interface
!  (or through the air-ice or air-snow interface)
!  is provided by the driving atmospheric model.
!
!  Empirical constants and parameters of the lake model
!  are estimated, using independent empirical and numerical data.
!  They should not be re-evaluated when the model is applied to a particular lake.
!  The only lake-specific parameters are the lake depth,
!  the optical characteristics of lake water,
!  the temperature at the bottom of the thermally active layer
!  of bottom sediments and the depth of that layer.
!
!  A detailed description of the lake model is given in
!  Mironov, D. V., 2005:
!  Parameterization of Lakes in Numerical Weather Prediction.
!  Part 1: Description of a Lake Model.
!  Manuscript is available from the author.
!  Dmitrii Mironov
!  German Weather Service, Kaiserleistr. 29/35, D-63067 Offenbach am Main, Germany.
!  dmitrii.mironov@dwd.de
!
!  Lines embraced with "!_tmp" contain temporary parts of the code.
!  Lines embraced/marked with "!_dev" may be replaced
!  as improved parameterizations are developed and tested.
!  Lines embraced/marked with "!_dm" are DM's comments
!  that may be helpful to a user.
!  Lines embraced/marked with "!_dbg" are used
!  for debugging purposes only.
!
!
! Current Code Owner: DWD, Dmitrii Mironov
!  Phone:  +49-69-8062 2705
!  Fax:    +49-69-8062 3721
!  E-mail: dmitrii.mironov@dwd.de
!
! History:
! Version    Date       Name
! ---------- ---------- ----
! 1.00       2005/11/17 Dmitrii Mironov
!  Initial release
! !VERSION!  !DATE!     <Your name>
!  <Modification comments>
!
! Code Description:
! Language: Fortran 90.
! Software Standards: "European Standards for Writing and
! Documenting Exchangeable Fortran 90 Code".
!==============================================================================
!
! Declarations:
!
! Modules used:

USE data_parameters , ONLY : &
  ireals                   , & ! KIND-type parameter for real variables
  iintegers                    ! KIND-type parameter for "normal" integer variables

!==============================================================================

IMPLICIT NONE

!==============================================================================
!
! Declarations
!
!  The variables declared below
!  are accessible to all program units of the MODULE flake.
!  Some of them should be USEd by the driving routines that call flake routines.
!  These are basically the quantities computed by FLake.
!  All variables declared below have a suffix "flk".

!  FLake variables of type REAL

!  Temperatures at the previous time step ("p") and the updated temperatures ("n")
REAL (KIND = ireals) ::           &
  T_mnw_p_flk, T_mnw_n_flk      , & ! Mean temperature of the water column [K]
  T_snow_p_flk, T_snow_n_flk    , & ! Temperature at the air-snow interface [K]
  T_ice_p_flk, T_ice_n_flk      , & ! Temperature at the snow-ice or air-ice interface [K]
  T_wML_p_flk, T_wML_n_flk      , & ! Mixed-layer temperature [K]
  T_bot_p_flk, T_bot_n_flk      , & ! Temperature at the water-bottom sediment interface [K]
  T_B1_p_flk, T_B1_n_flk            ! Temperature at the bottom of the upper layer of the sediments [K]

!  Thickness of various layers at the previous time step ("p") and the updated values ("n")
REAL (KIND = ireals) ::           &
  h_snow_p_flk, h_snow_n_flk    , & ! Snow thickness [m]
  h_ice_p_flk, h_ice_n_flk      , & ! Ice thickness [m]
  h_ML_p_flk, h_ML_n_flk        , & ! Thickness of the mixed-layer [m]
  H_B1_p_flk, H_B1_n_flk            ! Thickness of the upper layer of bottom sediments [m]

!  The shape factor(s) at the previous time step ("p") and the updated value(s) ("n")
REAL (KIND = ireals) ::           &
  C_T_p_flk, C_T_n_flk          , & ! Shape factor (thermocline)
  C_TT_flk                      , & ! Dimensionless parameter (thermocline)
  C_Q_flk                       , & ! Shape factor with respect to the heat flux (thermocline)
  C_I_flk                       , & ! Shape factor (ice)
  C_S_flk                           ! Shape factor (snow)

!  Derivatives of the shape functions
REAL (KIND = ireals) ::           &
  Phi_T_pr0_flk                 , & ! d\Phi_T(0)/d\zeta   (thermocline)
  Phi_I_pr0_flk                 , & ! d\Phi_I(0)/d\zeta_I (ice)
  Phi_I_pr1_flk                 , & ! d\Phi_I(1)/d\zeta_I (ice)
  Phi_S_pr0_flk                     ! d\Phi_S(0)/d\zeta_S (snow)

!  Heat and radiation fluxes
REAL (KIND = ireals) ::           &
  Q_snow_flk                    , & ! Heat flux through the air-snow interface [W m^{-2}]
  Q_ice_flk                     , & ! Heat flux through the snow-ice or air-ice interface [W m^{-2}]
  Q_w_flk                       , & ! Heat flux through the ice-water or air-water interface [W m^{-2}]
  Q_bot_flk                     , & ! Heat flux through the water-bottom sediment interface [W m^{-2}]
  I_atm_flk                     , & ! Radiation flux at the lower boundary of the atmosphere [W m^{-2}],
                                    ! i.e. the incident radiation flux with no regard for the surface albedo.
  I_snow_flk                    , & ! Radiation flux through the air-snow interface [W m^{-2}]
  I_ice_flk                     , & ! Radiation flux through the snow-ice or air-ice interface [W m^{-2}]
  I_w_flk                       , & ! Radiation flux through the ice-water or air-water interface [W m^{-2}]
  I_h_flk                       , & ! Radiation flux through the mixed-layer-thermocline interface [W m^{-2}]
  I_bot_flk                     , & ! Radiation flux through the water-bottom sediment interface [W m^{-2}]
  I_intm_0_h_flk                , & ! Mean radiation flux over the mixed layer [W m^{-1}]
  I_intm_h_D_flk                , & ! Mean radiation flux over the thermocline [W m^{-1}]
  Q_star_flk                        ! A generalized heat flux scale [W m^{-2}]

!  Velocity scales
REAL (KIND = ireals) ::           &
  u_star_w_flk                  , & ! Friction velocity in the surface layer of lake water [m s^{-1}]
  w_star_sfc_flk                    ! Convective velocity scale,
                                    ! using a generalized heat flux scale [m s^{-1}]

!  The rate of snow accumulation
REAL (KIND = ireals) ::           &
  dMsnowdt_flk                      ! The rate of snow accumulation [kg m^{-2} s^{-1}]

!==============================================================================
! Procedures
!==============================================================================

CONTAINS

!==============================================================================
!  The codes of the FLake procedures are stored in separate "*.incf" files
!  and are included below.
!------------------------------------------------------------------------------

!==============================================================================
include 'flake_radflux.incf'

!==============================================================================

!==============================================================================
include 'flake_driver.incf'

!==============================================================================

!==============================================================================
include 'flake_buoypar.incf'

!==============================================================================

!==============================================================================
include 'flake_snowdensity.incf'

!==============================================================================

!==============================================================================
include 'flake_snowheatconduct.incf'

!==============================================================================

END MODULE flake


program main
    use,intrinsic :: iso_fortran_env
    use double_merge_sort_mod
    use random_mod
    implicit none
    if (.not. test_double_merge_sort_int32()) error stop
    if (.not. test_double_merge_sort_int64()) error stop
    if (.not. test_double_merge_sort_char()) error stop
contains
    function test_double_merge_sort_int32() result(ret)
        integer(int32):: n,i
        integer(int32), allocatable:: ar1(:), ar2(:), ar3(:)
        logical:: ret

        n = 10000
        allocate(ar1(n), source=[(randint(n), i=1,n)])
        allocate(ar2(n), source=[(i, i=1,n)])
        allocate(ar3(n), source=ar1)
        call double_merge_sort(ar1,ar2)
        ret = .true.
        do i=2,n
            ret = ret .and. ar1(i) >= ar1(i-1)
        end do
        ar3 = [(ar3(ar2(i)), i=1,n)]
        ret = ret .and. sum(ar3-ar1)==0
    end function

    function test_double_merge_sort_int64() result(ret)
        integer(int64):: n,i
        integer(int64), allocatable:: ar1(:), ar2(:), ar3(:)
        logical:: ret

        n = 10000
        allocate(ar1(n), source=[(randint(n), i=1,n)])
        allocate(ar2(n), source=[(i, i=1,n)])
        allocate(ar3(n), source=ar1)
        call double_merge_sort(ar1,ar2)
        ret = .true.
        do i=2,n
            ret = ret .and. ar1(i) >= ar1(i-1)
        end do
        ar3 = [(ar3(ar2(i)), i=1,n)]
        ret = ret .and. sum(ar3-ar1)==0
    end function

    function test_double_merge_sort_char() result(ret)
        integer(int32):: n,i
        character(:), allocatable:: ar1(:), ar3(:)
        integer(int32), allocatable:: ar2(:)
        logical:: ret
        n=6
        allocate(character(100):: ar1(n))
        ar1(1) = 'banana'
        ar1(2) = 'orange'
        ar1(3) = 'apple'
        ar1(4) = 'intel'
        ar1(5) = 'amd'
        ar1(6) = 'nvidia'
        allocate(ar2(n), source=[(i,i=1,n)])
        allocate(ar3, source=ar1)
        call double_merge_sort(ar1, ar2)
        print*, (trim(ar1(i))//' : ', i=1,n)
        ret = .true.
        do i=2,n
            ret = ret .and. ar1(i) >= ar1(i-1)
        end do
        ar3 = [(ar3(ar2(i)), i=1,n)]
        ret = ret .and. all(ar3==ar1)
    end function
end program main


real, parameter :: pi = 3.141593


! Copyright (c) 2012, NVIDIA CORPORATION. All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
!  * Redistributions of source code must retain the above copyright
!    notice, this list of conditions and the following disclaimer.
!  * Redistributions in binary form must reproduce the above copyright
!    notice, this list of conditions and the following disclaimer in the
!    documentation and/or other materials provided with the distribution.
!  * Neither the name of NVIDIA CORPORATION nor the names of its
!    contributors may be used to endorse or promote products derived
!    from this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ``AS IS'' AND ANY
! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT OWNER OR
! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY
! OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

program jacobi
  use laplace2d
  implicit none
  integer, parameter :: fp_kind=kind(1.0d0)
  integer, parameter :: n=4096, m=4096, iter_max=1000
  integer :: i, j, iter
  real(fp_kind), dimension (:,:), allocatable :: A, Anew
  real(fp_kind) :: tol=1.0e-6_fp_kind, error=1.0_fp_kind
  real(fp_kind) :: start_time, stop_time

  ! allocate ( A(0:n-1,0:m-1), Anew(0:n-1,0:m-1) )

  ! A    = 0.0_fp_kind
  ! Anew = 0.0_fp_kind

  ! Set B.C.
  ! A(0,:)    = 1.0_fp_kind
  ! Anew(0,:) = 1.0_fp_kind

  call initialize(A, Anew, m, n)

  write(*,'(a,i5,a,i5,a)') 'Jacobi relaxation Calculation:', n, ' x', m, ' mesh'

  call cpu_time(start_time)

  iter=0

  !$acc data copy(A) create(Anew)
  do while ( error .gt. tol .and. iter .lt. iter_max )

    error = calcNext(A, Anew, m, n)
    call swap(A, Anew, m, n)

    if(mod(iter,100).eq.0 ) write(*,'(i5,f10.6)'), iter, error

    iter = iter + 1

  end do
  !$acc end data

  call cpu_time(stop_time)
  write(*,'(a,f10.3,a)')  ' completed in ', stop_time-start_time, ' seconds'

  ! deallocate (A,Anew)
end program jacobi


module precision
  integer, parameter :: rk = selected_real_kind(8)
  integer, parameter :: ik = selected_real_kind(4)
end module


! chk_do_concurrent_f2018.f90 --
!     Check: does the compiler support the DO CONCURRENT locality clauses (F2018)?
!
program chk_do_concurrent_f2018
    implicit none

    integer :: i
    real, dimension(1000) :: array
    real                  :: b

    do concurrent (i=1:size(array)) local( b )
        b        = exp(i/1000.0)
        array(i) = b**2
    enddo

    write( *, '(a)' ) 'The DO CONCURRENT construct is supported'
end program chk_do_concurrent_f2018


! $UWHPSC/codes/openmp/umax1.f90

! Solve n ODEs and stop when one reaches value of 100.
! With debug statements including +++ left in for illustration.

! Try removing the first omp barrier and code may hang.

program umax1

    use omp_lib
    implicit none
    real(kind=8), dimension(100) :: u,c
    real(kind=8) :: dt,umax,umax_thread
    integer :: n, nthreads, points_per_thread,thread_num
    integer :: m,i,istart,iend,nsteps
    logical :: debug

    debug = .false.

    ! Specify number of threads to use:
    nthreads = 1       ! need this value in serial mode
    !$ nthreads = 4
    !$ call omp_set_num_threads(nthreads)
    !$ print "('Using OpenMP with ',i3,' threads')", nthreads

    n = 100  ! number of ODEs

    ! Determine how many points to handle with each thread.
    ! Note that dividing two integers and assigning to an integer will
    ! round down if the result is not an integer.
    ! This, together with the min(...) in the definition of iend below,
    ! insures that all points will get distributed to some thread.
    points_per_thread = (n + nthreads - 1) / nthreads
    print *, "points_per_thread = ",points_per_thread

    u = 1.d0
    do i=1,n
        c(i) = dble(i - n/2)  ! some positive, some negative
        enddo

    dt = 0.01
    nsteps = 1000
    umax = 1.d0

    !$omp parallel private(i,m,umax_thread,istart,iend,thread_num)

    thread_num = 0     ! needed in serial mode
    !$ thread_num = omp_get_thread_num()    ! unique for each thread

    ! Determine start and end index for the set of points to be
    ! handled by this thread:
    istart = thread_num * points_per_thread + 1
    iend = min((thread_num+1) * points_per_thread, n)

    !$omp critical
    print 201, thread_num, istart, iend
    !$omp end critical
201 format("Thread ",i2," will take i = ",i6," through i = ",i6)

    do m=1,nsteps
        if (debug) then
            print 301, thread_num, m, umax
301         format("+++ begin loop      thread ",i3," m = ",i4,"  umax = ",f8.3)
            endif
        umax_thread = 0.d0
        !$omp single
          umax = 0.d0
        !$omp end single
        do i=istart,iend
            u(i) = (1.d0 + c(i)*dt) * u(i)
            umax_thread = max(umax_thread, u(i))
            enddo

        ! update global umax with value from each thread:
        !$omp critical
          umax = max(umax, umax_thread)
        !$omp end critical

        ! make sure all have updated umax before proceeding:
        !$omp barrier
		! Try removing the barrier above, in which case the code
		! will sometimes hang --- quit out with ctrl-c

        if (umax > 100) then
            if (debug) then
               print 302, thread_num, m, umax, umax_thread
302            format("+++ umax>100: exit  thread ",i3," m = ",i4,"  umax = ",f8.3,"  umax_thread = ",f8.3)
               endif
            exit
            endif

        if (debug) then
           print 303, thread_num, m, umax, umax_thread
303        format("+++ umax<100        thread ",i3," m = ",i4,"  umax = ",f8.3,"  umax_thread = ",f8.3)
           endif

        ! make sure all threads are done testing umax before going
        ! on to next iteration (where umax is re-initialized to 0).
        !$omp barrier
        enddo
    !$omp end parallel

    print *, 'Done!  umax = ', umax

end program umax1


SUBROUTINE bc_rect(nxe,nye,nf,dir)
! Used in p63, p66, p67, p68
! This subroutine generates the nf array for a rectangular mesh
! of '8-node quadrilaterals' fully fixed on the base and with
! vertical rollers on the left and right sides. Nodes numbered
! in the x- or y-direction
!
 IMPLICIT NONE
 ! nie : [integer] elements counting in i-direction
 INTEGER,INTENT(IN)::nxe,nye
 ! dir : [string] x or y or z
 CHARACTER(LEN=1),INTENT(IN)::dir
 !  nf : [integer] node freedom array e.g. nf(1,0)=1
 INTEGER,INTENT(OUT)::nf(:,:)
 INTEGER::nm,ic,i,j
 !
 IF(dir=='y')THEN
   nm=0
   ic=0
   DO j=1,2*nye
     nm=nm+1
     nf(1,nm)=0
     ic=ic+1
     nf(2,nm)=ic
   END DO
   nm=nm+1
   nf(1,nm)=0
   nf(2,nm)=0
  !
   DO i=1,nxe-1
     DO j=1,nye
       nm=nm+1
       ic=ic+1
       nf(1,nm)=ic
       ic=ic+1
       nf(2,nm)=ic
     END DO
     nm=nm+1
     nf(1,nm)=0
     nf(2,nm)=0
  !
     DO j=1,2*nye
       nm=nm+1
       ic=ic+1
       nf(1,nm)=ic
       ic=ic+1
       nf(2,nm)=ic
     END DO
     nm=nm+1
     nf(1,nm)=0
     nf(2,nm)=0
   END DO
  !
   DO j=1,nye
     nm=nm+1
     ic=ic+1
     nf(1,nm)=ic
     ic=ic+1
     nf(2,nm)=ic
   END DO
   nm=nm+1
   nf(1,nm)=0
   nf(2,nm)=0
  !
   DO j=1,2*nye
     nm=nm+1
     nf(1,nm)=0
     ic=ic+1
     nf(2,nm)=ic
   END DO
   nm=nm+1
   nf(1,nm)=0
   nf(2,nm)=0
 ELSE
   nm=0
   ic=0
   DO j=1,nye
     nm=nm+1
     nf(1,nm)=0
     ic=ic+1
     nf(2,nm)=ic
     DO i=1,2*nxe-1
       nm=nm+1
       ic=ic+1
       nf(1,nm)=ic
       ic=ic+1
       nf(2,nm)=ic
     END DO
     nm=nm+1
     nf(1,nm)=0
     ic=ic+1
     nf(2,nm)=ic
!
     nm=nm+1
     nf(1,nm)=0
     ic=ic+1
     nf(2,nm)=ic
     DO i=1,nxe-1
       nm=nm+1
       ic=ic+1
       nf(1,nm)=ic
       ic=ic+1
       nf(2,nm)=ic
     END DO
     nm=nm+1
     nf(1,nm)=0
     ic=ic+1
     nf(2,nm)=ic
   END DO
!
   DO i=1,2*nxe+1
     nm=nm+1
     nf(1,nm)=0
     nf(2,nm)=0
   END DO
 END IF
 RETURN
END SUBROUTINE bc_rect


c
c ----------------------------------------------------------
c
      subroutine moment (rect,badpts,npt,usage,buffx,buffy,hx,hy)
c
      implicit double precision (a-h,o-z)
      dimension     rect(12),badpts(2,npt)
c
c input parameters:
c     badpts      = x,y coords of flagged badpts grouped into clusters
c                   are in the first two rows
c     npt         = num. of badpts. in the cluster.
c     buffx,y     = expand new grids with buffer zone of size buffer.
c                   this also prevents degenerate point rectangles.
c output parameters:
c     usage       = ratio of flagged to unflagged badpts. in new grid
c                   measures goodness of fit and clustering
c    rect( )      = stores some info. for grid created herein.
c                   sometimes rect = rnode, sometimes = temp. array.
c                   depending on calling prog. (grdfit or expand)
c
c
c  moment = compute rectangle around flagged points.
c  save some info., even tho. usage might be low and rect. scrapped.
c
      rn = dfloat(npt)
c
c compute length of enclosing rectangles to include all flagged badpts.
c expand on all sides by 'buffer' zone.  this also prevents
c case of degenerate rectangle (line).
c
      emx1 = badpts(1,1)
      emn1 = emx1
      emx2 = badpts(2,1)
      emn2 = emx2
      do 80 ipt = 1, npt
          if (badpts(1,ipt) .gt. emx1) emx1 = badpts(1,ipt)
          if (badpts(1,ipt) .lt. emn1) emn1 = badpts(1,ipt)
          if (badpts(2,ipt) .gt. emx2) emx2 = badpts(2,ipt)
          if (badpts(2,ipt) .lt. emn2) emn2 = badpts(2,ipt)
 80   continue
      emx1  = emx1 + buffx
      emx2  = emx2 + buffy
      emn1  = emn1 - buffx
      emn2  = emn2 - buffy
c
c from length of the sides, determine the 4 rect. corners
c number the corners clockwise
c
      rect(1) = emn1
      rect(2) = emn2
      rect(3) = emn1
      rect(4) = emx2
      rect(5) = emx1
      rect(6) = emx2
      rect(7) = emx1
      rect(8) = emn2
c
c compute volume cutoff ratio
c
      iside1 = (hx+emx1-emn1-2.0*buffx+.00001) / hx
      iside2 = (hy+emx2-emn2-2.0*buffy+.00001) / hy
      gpall  = iside1 * iside2
      usage  = rn / gpall
c
      return
      end


      INTEGER FUNCTION MODTRN (DIM)

C  MODTRN performs a random transformation on six line segments using
C  various modelling facilities, and marks the expected endpoints
C  with circle-polymarkers.  It returns the identifier of the line
C  segment which is marked incorrectly.
C
C  Input parameter:
C     DIM: dimensionality of the transformations to be tested (2 or 3)

      COMMON /DIALOG/ DOUTYP, DINTYP, DSTDNR, DSTRID, PSTRID, DTCLIM,
     1                SCRMOD, DTXCI, SPECWT,
     2                DSIZE, EFRAC, DYXRAT, SYXRAT, MTRPDC, WCPDC, QVIS
      INTEGER         DOUTYP, DINTYP, DSTDNR, DSTRID, PSTRID, DTCLIM,
     1                SCRMOD, DTXCI, SPECWT
      REAL            DSIZE, EFRAC, DYXRAT, SYXRAT, MTRPDC, WCPDC, QVIS

C composition type
C                preconcatenate  postconcatenate  replace
      INTEGER    PCPRE,          PCPOST,          PCREPL
      PARAMETER (PCPRE = 0,      PCPOST = 1,      PCREPL = 2)

C Marker type
      INTEGER    PPOINT,   PPLUS,   PAST,   POMARK,   PXMARK
      PARAMETER (PPOINT=1, PPLUS=2, PAST=3, POMARK=4, PXMARK=5)

      REAL       PI
      PARAMETER (PI = 3.14159265)

      INTEGER DIM, LISBOX(6), THIS, IX, RNDINT, NGBOX

      REAL XSIZ, YSIZ, XWINLO(6), YWINLO(6)
      REAL IDXF(4,4), XF(4,4), TMP4(4,4), BOXF(4,4), FIXF(4,4)
      REAL ROTXF(4,4), WC1X,WC1Y,WC1Z, WC2X,WC2Y,WC2Z, XF2(3,3)
      REAL XA(2),YA(2), PX(2),PY(2),PZ(2), NGXF(4,4)
      REAL XSCF, YSCF, ZSCF, XMID, YMID, ZMID, XSHF, YSHF, ZSHF

      DATA PX / 1.0, 2.0 /, PY / 1.0, 2.0 /, PZ / 1.0, 2.0 /

C  Set up structure 106 to label 6 windows
      CALL WIN6 (106, 1, XSIZ,YSIZ, XWINLO, YWINLO)
C  Open test structure
      CALL POPST (102)
C  Set polymarker type
      CALL PSMK   (POMARK)
C  Initialize identity matrix
      CALL IDMAT (4,IDXF)

      CALL RNPERM (6,LISBOX)
C  box to be drawn incorrectly
      NGBOX = RNDINT(1,6)

      CALL PSPLCI (2)
      CALL PSPMCI (3)

      DO 100, IX = 1,6
         THIS = LISBOX(IX)

         IF (DIM .EQ. 2) THEN
C  set up for 2D
            CALL RANARY (3, XF2)
            CALL EXP34 (XF2,XF)
         ELSEIF (DIM .EQ. 3) THEN
C  set up for 3D
            CALL RANARY (4, XF)
         ELSE
            CALL UNMSG ('MODTRN called with invalid dimension.')
         ENDIF

         IF ((THIS.EQ.1) .OR. (THIS.EQ.4)) THEN
C  Rotate 90 around x axis
            CALL EROX ( PI/2., ROTXF)
         ELSE IF ((THIS.EQ.2) .OR. (THIS.EQ.5)) THEN
C  Rotate 90 around y axis
            CALL EROY ( PI/2., ROTXF)
         ELSE
C  Rotate 90 around z axis
            CALL EROZ ( PI/2., ROTXF)
         ENDIF
C
C  Compose new transformation matrix
         CALL ECOM3 (ROTXF,XF,TMP4)
C
C  Calculate transformation by ROTXF x XF of (1,1,1) and (2,2,2)
         CALL ETP3 (PX(1),PY(1),PZ(1), TMP4, WC1X,WC1Y,WC1Z)
         CALL ETP3 (PX(2),PY(2),PZ(2), TMP4, WC2X,WC2Y,WC2Z)

         XSCF = 0.8 * XSIZ / ( WC2X - WC1X )
         YSCF = 0.8 * YSIZ / ( WC2Y - WC1Y )
         ZSCF = 0.8        / ( WC2Z - WC1Z )

         XMID = XSCF * ( WC1X + WC2X )/2
         YMID = YSCF * ( WC1Y + WC2Y )/2
         ZMID = ZSCF * ( WC1Z + WC2Z )/2

         XSHF = XWINLO(IX) + XSIZ/2 - XMID
         YSHF = YWINLO(IX) + YSIZ/2 - YMID
         ZSHF = 0.5                 - ZMID

         CALL EBLTM3 (0.,0.,0., XSHF,YSHF,ZSHF, 0.,0.,0.,
     1                XSCF,YSCF,ZSCF, BOXF)
C
C  Compose new transformation matrix = BOX x ROTXF x XF
         CALL ECOM3 (BOXF,ROTXF,FIXF)
         CALL ECOM3 (FIXF,XF,TMP4)
C
C  Calculate expected positions of (1,1,1) and (2,2,2)
         CALL ETP3 (PX(1),PY(1),PZ(1), TMP4, WC1X,WC1Y,WC1Z)
         CALL ETP3 (PX(2),PY(2),PZ(2), TMP4, WC2X,WC2Y,WC2Z)

         IF ( IX .EQ. NGBOX) THEN
C  distort result - rotate by 10 degrees
            CALL EBLTM3 (XWINLO(IX) + XSIZ/2, YWINLO(IX) + YSIZ/2 , 0.5,
     1                   0.,0.,0.,  0.,0.,(2*PI*10)/360,
     2                   1.0,1.0,1.0, NGXF)
            CALL ECOM3 (NGXF,FIXF,TMP4)
            CALL CPYIAR (16,TMP4,FIXF)
         ENDIF

         IF ( THIS .LT. 3 ) THEN
            CALL PSLMT3 (FIXF,PCREPL)
            IF (DIM .EQ. 2 ) THEN
               CALL PSLMT (XF2,PCPRE)
            ELSE
               CALL PSLMT3 (XF,PCPRE)
            ENDIF
         ELSEIF ( THIS .LT. 5 ) THEN
            IF (DIM .EQ. 2 ) THEN
               CALL PSLMT (XF2,PCREPL)
            ELSE
               CALL PSLMT3 (XF,PCREPL)
            ENDIF
            CALL PSLMT3 (FIXF,PCPOST)
         ELSE
            IF (DIM .EQ. 2 ) THEN
               CALL PSLMT (XF2,PCREPL)
            ELSE
               CALL PSLMT3 (XF,PCREPL)
            ENDIF
            CALL PSGMT3 (FIXF)
         ENDIF

C  Draw line segment as changed by transformation matrix
         CALL PPL3 (2,PX,PY,PZ)

C  Now expected endpoints with no transformations
         CALL PSLMT3 (IDXF,PCREPL)
         CALL PSGMT3 (IDXF)

         XA(1) = WC1X
         YA(1) = WC1Y
         XA(2) = WC2X
         YA(2) = WC2Y
         CALL PPM (2, XA,YA)
100   CONTINUE
      CALL PCLST
      MODTRN = NGBOX

      END


      SUBROUTINE svbksb(u,w,v,m,n,mp,np,b,x)
      INTEGER m,mp,n,np,NMAX
      DOUBLE PRECISION b(mp),u(mp,np),v(np,np),w(np),x(np)
      include 'param.inc'
c      PARAMETER (NMAX=2000)    ! Maximum anticipated value of n.
c      Solves A â X = B for a vector X, where A is specified by the arrays u, w, v as returned by
c      svdcmp. m and n are the logical dimensions of a, and will be equal for square matrices. mp
c      and np are the physical dimensions of a. b(1:m) is the input right-hand side. x(1:n) is
c      the output solution vector. No input quantities are destroyed, so the routine may be called
c      sequentially with different bÃs.
      INTEGER i,j,jj
      DOUBLE PRECISION s,tmp(maxdata)
      do 12 j=1,n             ! Calculate UTB.
      s=0.
      if(w(j).ne.0.)then      ! Nonzero result only if wj is nonzero.
      do 11 i=1,m
      s=s+u(i,j)*b(i)
 11   enddo
      s=s/w(j)                ! This is the divide by wj .
      endif
      tmp(j)=s
 12   enddo
      do 14 j=1,n             ! Matrix multiply by V to get answer.
      s=0.
      do 13 jj=1,n
      s=s+v(j,jj)*tmp(jj)
 13   enddo
      x(j)=s
 14   enddo
      return
      END