      SUBROUTINE DRMNFB(B, D, FX, IV, LIV, LV, P, V, X)
C
C  ***  ITERATION DRIVER FOR  DMNF...
C  ***  MINIMIZE GENERAL UNCONSTRAINED OBJECTIVE FUNCTION USING
C  ***  FINITE-DIFFERENCE GRADIENTS AND SECANT HESSIAN APPROXIMATIONS.
C
      INTEGER LIV, LV, P
      INTEGER IV(LIV)
      DOUBLE PRECISION B(2,P), D(P), FX, X(P), V(LV)
C     DIMENSION IV(59 + P), V(77 + P*(P+23)/2)
C
C  ***  PURPOSE  ***
C
C        THIS ROUTINE INTERACTS WITH SUBROUTINE  DRMNGB  IN AN ATTEMPT
C     TO FIND AN P-VECTOR  X*  THAT MINIMIZES THE (UNCONSTRAINED)
C     OBJECTIVE FUNCTION  FX = F(X)  COMPUTED BY THE CALLER.  (OFTEN
C     THE  X*  FOUND IS A LOCAL MINIMIZER RATHER THAN A GLOBAL ONE.)
C
C  ***  PARAMETERS  ***
C
C        THE PARAMETERS FOR DRMNFB ARE THE SAME AS THOSE FOR  DMNG
C     (WHICH SEE), EXCEPT THAT CALCF, CALCG, UIPARM, URPARM, AND UFPARM
C     ARE OMITTED, AND A PARAMETER  FX  FOR THE OBJECTIVE FUNCTION
C     VALUE AT X IS ADDED.  INSTEAD OF CALLING CALCG TO OBTAIN THE
C     GRADIENT OF THE OBJECTIVE FUNCTION AT X, DRMNFB CALLS DS3GRD,
C     WHICH COMPUTES AN APPROXIMATION TO THE GRADIENT BY FINITE
C     (FORWARD AND CENTRAL) DIFFERENCES USING THE METHOD OF REF. 1.
C     THE FOLLOWING INPUT COMPONENT IS OF INTEREST IN THIS REGARD
C     (AND IS NOT DESCRIBED IN  DMNG).
C
C V(ETA0)..... V(42) IS AN ESTIMATED BOUND ON THE RELATIVE ERROR IN THE
C             OBJECTIVE FUNCTION VALUE COMPUTED BY CALCF...
C                  (TRUE VALUE) = (COMPUTED VALUE) * (1 + E),
C             WHERE ABS(E) .LE. V(ETA0).  DEFAULT = MACHEP * 10**3,
C             WHERE MACHEP IS THE UNIT ROUNDOFF.
C
C        THE OUTPUT VALUES IV(NFCALL) AND IV(NGCALL) HAVE DIFFERENT
C     MEANINGS FOR  DMNF THAN FOR  DMNG...
C
C IV(NFCALL)... IV(6) IS THE NUMBER OF CALLS SO FAR MADE ON CALCF (I.E.,
C             FUNCTION EVALUATIONS) EXCLUDING THOSE MADE ONLY FOR
C             COMPUTING GRADIENTS.  THE INPUT VALUE IV(MXFCAL) IS A
C             LIMIT ON IV(NFCALL).
C IV(NGCALL)... IV(30) IS THE NUMBER OF FUNCTION EVALUATIONS MADE ONLY
C             FOR COMPUTING GRADIENTS.  THE TOTAL NUMBER OF FUNCTION
C             EVALUATIONS IS THUS  IV(NFCALL) + IV(NGCALL).
C
C  ***  REFERENCES  ***
C
C 1. STEWART, G.W. (1967), A MODIFICATION OF DAVIDON*S MINIMIZATION
C        METHOD TO ACCEPT DIFFERENCE APPROXIMATIONS OF DERIVATIVES,
C        J. ASSOC. COMPUT. MACH. 14, PP. 72-83.
C.
C  ***  GENERAL  ***
C
C     CODED BY DAVID M. GAY (AUGUST 1982).
C
C----------------------------  DECLARATIONS  ---------------------------
C
      DOUBLE PRECISION DD7TPR
      EXTERNAL DIVSET, DD7TPR, DS3GRD, DRMNGB, DV7SCP
C
C DIVSET.... SUPPLIES DEFAULT PARAMETER VALUES.
C DD7TPR... RETURNS INNER PRODUCT OF TWO VECTORS.
C DS3GRD... COMPUTES FINITE-DIFFERENCE GRADIENT APPROXIMATION.
C DRMNGB... REVERSE-COMMUNICATION ROUTINE THAT DOES  DMNGB ALGORITHM.
C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
C
      INTEGER ALPHA, ALPHA0, G1, I, IPI, IV1, J, K, W
      DOUBLE PRECISION ZERO
C
C  ***  SUBSCRIPTS FOR IV   ***
C
      INTEGER ETA0, F, G, LMAT, NEXTV, NGCALL,
     1        NITER, PERM, SGIRC, TOOBIG, VNEED
C
C/6
C     DATA ETA0/42/, F/10/, G/28/, LMAT/42/, NEXTV/47/, NGCALL/30/,
C    1     NITER/31/, PERM/58/, SGIRC/57/, TOOBIG/2/, VNEED/4/
C/7
      PARAMETER (ETA0=42, F=10, G=28, LMAT=42, NEXTV=47, NGCALL=30,
     1           NITER=31, PERM=58, SGIRC=57, TOOBIG=2, VNEED=4)
C/
C/6
C     DATA ZERO/0.D+0/
C/7
      PARAMETER (ZERO=0.D+0)
C/
C
C+++++++++++++++++++++++++++++++  BODY  ++++++++++++++++++++++++++++++++
C
      IV1 = IV(1)
      IF (IV1 .EQ. 1) GO TO 10
      IF (IV1 .EQ. 2) GO TO 50
      IF (IV(1) .EQ. 0) CALL DIVSET(2, IV, LIV, LV, V)
      IV1 = IV(1)
      IF (IV1 .EQ. 12 .OR. IV1 .EQ. 13) IV(VNEED) = IV(VNEED) + 2*P + 6
      IF (IV1 .EQ. 14) GO TO 10
      IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10
      G1 = 1
      IF (IV1 .EQ. 12) IV(1) = 13
      GO TO 20
C
 10   G1 = IV(G)
C
 20   CALL DRMNGB(B, D, FX, V(G1), IV, LIV, LV, P, V, X)
      IF (IV(1) - 2) 999, 30, 80
C
C  ***  COMPUTE GRADIENT  ***
C
 30   IF (IV(NITER) .EQ. 0) CALL DV7SCP(P, V(G1), ZERO)
      J = IV(LMAT)
      ALPHA0 = G1 - P - 1
      IPI = IV(PERM)
      DO 40 I = 1, P
         K = ALPHA0 + IV(IPI)
         V(K) = DD7TPR(I, V(J), V(J))
         IPI = IPI + 1
         J = J + I
 40      CONTINUE
C     ***  UNDO INCREMENT OF IV(NGCALL) DONE BY DRMNGB  ***
      IV(NGCALL) = IV(NGCALL) - 1
C     ***  STORE RETURN CODE FROM DS3GRD IN IV(SGIRC)  ***
      IV(SGIRC) = 0
C     ***  X MAY HAVE BEEN RESTORED, SO COPY BACK FX... ***
      FX = V(F)
      GO TO 60
C
C     ***  GRADIENT LOOP  ***
C
 50   IF (IV(TOOBIG) .NE. 0) GO TO 10
C
 60   G1 = IV(G)
      ALPHA = G1 - P
      W = ALPHA - 6
      CALL DS3GRD(V(ALPHA), B, D, V(ETA0), FX, V(G1), IV(SGIRC), P,
     1            V(W), X)
      I = IV(SGIRC)
      IF (I .EQ. 0) GO TO 10
      IF (I .LE. P) GO TO 70
         IV(TOOBIG) = 1
         GO TO 10
C
 70   IV(NGCALL) = IV(NGCALL) + 1
      GO TO 999
C
 80   IF (IV(1) .NE. 14) GO TO 999
C
C  ***  STORAGE ALLOCATION  ***
C
      IV(G) = IV(NEXTV) + P + 6
      IV(NEXTV) = IV(G) + P
      IF (IV1 .NE. 13) GO TO 10
C
 999  RETURN
C  ***  LAST CARD OF DRMNFB FOLLOWS  ***
      END
      SUBROUTINE DS3GRD(ALPHA, B, D, ETA0, FX, G, IRC, P, W, X)
C
C  ***  COMPUTE FINITE DIFFERENCE GRADIENT BY STWEART*S SCHEME  ***
C
C     ***  PARAMETERS  ***
C
      INTEGER IRC, P
      DOUBLE PRECISION ALPHA(P), B(2,P), D(P), ETA0, FX, G(P), W(6),
     1                 X(P)
C
C.......................................................................
C
C     ***  PURPOSE  ***
C
C        THIS SUBROUTINE USES AN EMBELLISHED FORM OF THE FINITE-DIFFER-
C     ENCE SCHEME PROPOSED BY STEWART (REF. 1) TO APPROXIMATE THE
C     GRADIENT OF THE FUNCTION F(X), WHOSE VALUES ARE SUPPLIED BY
C     REVERSE COMMUNICATION.
C
C     ***  PARAMETER DESCRIPTION  ***
C
C  ALPHA IN  (APPROXIMATE) DIAGONAL ELEMENTS OF THE HESSIAN OF F(X).
C      B IN  ARRAY OF SIMPLE LOWER AND UPPER BOUNDS ON X.  X MUST
C             SATISFY B(1,I) .LE. X(I) .LE. B(2,I), I = 1(1)P.
C             FOR ALL I WITH B(1,I) .GE. B(2,I), DS3GRD SIMPLY
C             SETS G(I) TO 0.
C      D IN  SCALE VECTOR SUCH THAT D(I)*X(I), I = 1,...,P, ARE IN
C             COMPARABLE UNITS.
C   ETA0 IN  ESTIMATED BOUND ON RELATIVE ERROR IN THE FUNCTION VALUE...
C             (TRUE VALUE) = (COMPUTED VALUE)*(1+E),   WHERE
C             ABS(E) .LE. ETA0.
C     FX I/O ON INPUT,  FX  MUST BE THE COMPUTED VALUE OF F(X).  ON
C             OUTPUT WITH IRC = 0, FX HAS BEEN RESTORED TO ITS ORIGINAL
C             VALUE, THE ONE IT HAD WHEN DS3GRD WAS LAST CALLED WITH
C             IRC = 0.
C      G I/O ON INPUT WITH IRC = 0, G SHOULD CONTAIN AN APPROXIMATION
C             TO THE GRADIENT OF F NEAR X, E.G., THE GRADIENT AT THE
C             PREVIOUS ITERATE.  WHEN DS3GRD RETURNS WITH IRC = 0, G IS
C             THE DESIRED FINITE-DIFFERENCE APPROXIMATION TO THE
C             GRADIENT AT X.
C    IRC I/O INPUT/RETURN CODE... BEFORE THE VERY FIRST CALL ON DS3GRD,
C             THE CALLER MUST SET IRC TO 0.  WHENEVER DS3GRD RETURNS A
C             NONZERO VALUE (OF AT MOST P) FOR IRC, IT HAS PERTURBED
C             SOME COMPONENT OF X... THE CALLER SHOULD EVALUATE F(X)
C             AND CALL DS3GRD AGAIN WITH FX = F(X).  IF B PREVENTS
C             ESTIMATING G(I) I.E., IF THERE IS AN I WITH
C             B(1,I) .LT. B(2,I) BUT WITH B(1,I) SO CLOSE TO B(2,I)
C             THAT THE FINITE-DIFFERENCING STEPS CANNOT BE CHOSEN,
C             THEN DS3GRD RETURNS WITH IRC .GT. P.
C      P IN  THE NUMBER OF VARIABLES (COMPONENTS OF X) ON WHICH F
C             DEPENDS.
C      X I/O ON INPUT WITH IRC = 0, X IS THE POINT AT WHICH THE
C             GRADIENT OF F IS DESIRED.  ON OUTPUT WITH IRC NONZERO, X
C             IS THE POINT AT WHICH F SHOULD BE EVALUATED.  ON OUTPUT
C             WITH IRC = 0, X HAS BEEN RESTORED TO ITS ORIGINAL VALUE
C             (THE ONE IT HAD WHEN DS3GRD WAS LAST CALLED WITH IRC = 0)
C             AND G CONTAINS THE DESIRED GRADIENT APPROXIMATION.
C      W I/O WORK VECTOR OF LENGTH 6 IN WHICH DS3GRD SAVES CERTAIN
C             QUANTITIES WHILE THE CALLER IS EVALUATING F(X) AT A
C             PERTURBED X.
C
C     ***  APPLICATION AND USAGE RESTRICTIONS  ***
C
C        THIS ROUTINE IS INTENDED FOR USE WITH QUASI-NEWTON ROUTINES
C     FOR UNCONSTRAINED MINIMIZATION (IN WHICH CASE  ALPHA  COMES FROM
C     THE DIAGONAL OF THE QUASI-NEWTON HESSIAN APPROXIMATION).
C
C     ***  ALGORITHM NOTES  ***
C
C        THIS CODE DEPARTS FROM THE SCHEME PROPOSED BY STEWART (REF. 1)
C     IN ITS GUARDING AGAINST OVERLY LARGE OR SMALL STEP SIZES AND ITS
C     HANDLING OF SPECIAL CASES (SUCH AS ZERO COMPONENTS OF ALPHA OR G).
C
C     ***  REFERENCES  ***
C
C 1. STEWART, G.W. (1967), A MODIFICATION OF DAVIDON*S MINIMIZATION
C        METHOD TO ACCEPT DIFFERENCE APPROXIMATIONS OF DERIVATIVES,
C        J. ASSOC. COMPUT. MACH. 14, PP. 72-83.
C
C     ***  HISTORY  ***
C
C     DESIGNED AND CODED BY DAVID M. GAY (SUMMER 1977/SUMMER 1980).
C
C     ***  GENERAL  ***
C
C        THIS ROUTINE WAS PREPARED IN CONNECTION WITH WORK SUPPORTED BY
C     THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS MCS76-00324 AND
C     MCS-7906671.
C
C.......................................................................
C
C     *****  EXTERNAL FUNCTION  *****
C
      DOUBLE PRECISION DR7MDC
      EXTERNAL DR7MDC
C DR7MDC... RETURNS MACHINE-DEPENDENT CONSTANTS.
C
C     ***** INTRINSIC FUNCTIONS *****
C/+
      DOUBLE PRECISION DSQRT
C/
C     ***** LOCAL VARIABLES *****
C
      LOGICAL HIT
      INTEGER FH, FX0, HSAVE, I, XISAVE
      DOUBLE PRECISION AAI, AFX, AFXETA, AGI, ALPHAI, AXI, AXIBAR,
     1                 DISCON, ETA, GI, H, HMIN, XI, XIH
      DOUBLE PRECISION C2000, FOUR, HMAX0, HMIN0, H0, MACHEP, ONE, P002,
     1                 THREE, TWO, ZERO
C
C/6
C     DATA C2000/2.0D+3/, FOUR/4.0D+0/, HMAX0/0.02D+0/, HMIN0/5.0D+1/,
C    1     ONE/1.0D+0/, P002/0.002D+0/, THREE/3.0D+0/,
C    2     TWO/2.0D+0/, ZERO/0.0D+0/
C/7
      PARAMETER (C2000=2.0D+3, FOUR=4.0D+0, HMAX0=0.02D+0, HMIN0=5.0D+1,
     1     ONE=1.0D+0, P002=0.002D+0, THREE=3.0D+0,
     2     TWO=2.0D+0, ZERO=0.0D+0)
C/
C/6
C     DATA FH/3/, FX0/4/, HSAVE/5/, XISAVE/6/
C/7
      PARAMETER (FH=3, FX0=4, HSAVE=5, XISAVE=6)
C/
C
C---------------------------------  BODY  ------------------------------
C
      IF (IRC) 80, 10, 210
C
C     ***  FRESH START -- GET MACHINE-DEPENDENT CONSTANTS  ***
C
C     STORE MACHEP IN W(1) AND H0 IN W(2), WHERE MACHEP IS THE UNIT
C     ROUNDOFF (THE SMALLEST POSITIVE NUMBER SUCH THAT
C     1 + MACHEP .GT. 1  AND  1 - MACHEP .LT. 1),  AND  H0 IS THE
C     SQUARE-ROOT OF MACHEP.
C
 10   W(1) = DR7MDC(3)
      W(2) = DSQRT(W(1))
C
      W(FX0) = FX
C
C     ***  INCREMENT  I  AND START COMPUTING  G(I)  ***
C
 20   I = IABS(IRC) + 1
      IF (I .GT. P) GO TO 220
         IRC = I
         IF (B(1,I) .LT. B(2,I)) GO TO 30
            G(I) = ZERO
            GO TO 20
 30      AFX = DABS(W(FX0))
         MACHEP = W(1)
         H0 = W(2)
         HMIN = HMIN0 * MACHEP
         XI = X(I)
         W(XISAVE) = XI
         AXI = DABS(XI)
         AXIBAR = DMAX1(AXI, ONE/D(I))
         GI = G(I)
         AGI = DABS(GI)
         ETA = DABS(ETA0)
         IF (AFX .GT. ZERO) ETA = DMAX1(ETA, AGI*AXI*MACHEP/AFX)
         ALPHAI = ALPHA(I)
         IF (ALPHAI .EQ. ZERO) GO TO 130
         IF (GI .EQ. ZERO .OR. FX .EQ. ZERO) GO TO 140
         AFXETA = AFX*ETA
         AAI = DABS(ALPHAI)
C
C        *** COMPUTE H = STEWART*S FORWARD-DIFFERENCE STEP SIZE.
C
         IF (GI**2 .LE. AFXETA*AAI) GO TO 40
              H = TWO*DSQRT(AFXETA/AAI)
              H = H*(ONE - AAI*H/(THREE*AAI*H + FOUR*AGI))
              GO TO 50
C40      H = TWO*(AFXETA*AGI/(AAI**2))**(ONE/THREE)
 40      H = TWO * (AFXETA*AGI)**(ONE/THREE) * AAI**(-TWO/THREE)
         H = H*(ONE - TWO*AGI/(THREE*AAI*H + FOUR*AGI))
C
C        ***  ENSURE THAT  H  IS NOT INSIGNIFICANTLY SMALL  ***
C
 50      H = DMAX1(H, HMIN*AXIBAR)
C
C        *** USE FORWARD DIFFERENCE IF BOUND ON TRUNCATION ERROR IS AT
C        *** MOST 10**-3.
C
         IF (AAI*H .LE. P002*AGI) GO TO 120
C
C        *** COMPUTE H = STEWART*S STEP FOR CENTRAL DIFFERENCE.
C
         DISCON = C2000*AFXETA
         H = DISCON/(AGI + DSQRT(GI**2 + AAI*DISCON))
C
C        ***  ENSURE THAT  H  IS NEITHER TOO SMALL NOR TOO BIG  ***
C
         H = DMAX1(H, HMIN*AXIBAR)
         IF (H .GE. HMAX0*AXIBAR) H = AXIBAR * H0**(TWO/THREE)
C
C        ***  COMPUTE CENTRAL DIFFERENCE  ***
C
         XIH = XI + H
         IF (XI - H .LT. B(1,I)) GO TO 60
         IRC = -I
         IF (XIH .LE. B(2,I)) GO TO 200
            H = -H
            XIH = XI + H
            IF (XI + TWO*H .LT. B(1,I)) GO TO 190
            GO TO 70
 60      IF (XI + TWO*H .GT. B(2,I)) GO TO 190
C        *** MUST DO OFF-SIDE CENTRAL DIFFERENCE ***
 70      IRC = -(I + P)
         GO TO 200
C
 80      I = -IRC
         IF (I .LE. P) GO TO 100
         I = I - P
         IF (I .GT. P) GO TO 90
         W(FH) = FX
         H = TWO * W(HSAVE)
         XIH = W(XISAVE) + H
         IRC = IRC - P
         GO TO 200
C
C    *** FINISH OFF-SIDE CENTRAL DIFFERENCE ***
C
 90      I = I - P
         G(I) = (FOUR*W(FH) - FX - THREE*W(FX0)) / W(HSAVE)
         IRC = I
         X(I) = W(XISAVE)
         GO TO 20
C
 100     H = -W(HSAVE)
         IF (H .GT. ZERO) GO TO 110
         W(FH) = FX
         XIH = W(XISAVE) + H
         GO TO 200
C
 110     G(I) = (W(FH) - FX) / (TWO * H)
         X(I) = W(XISAVE)
         GO TO 20
C
C     ***  COMPUTE FORWARD DIFFERENCES IN VARIOUS CASES  ***
C
 120     IF (H .GE. HMAX0*AXIBAR) H = H0 * AXIBAR
         IF (ALPHAI*GI .LT. ZERO) H = -H
         GO TO 150
 130     H = AXIBAR
         GO TO 150
 140     H = H0 * AXIBAR
C
 150     HIT = .FALSE.
 160     XIH = XI + H
         IF (H .GT. ZERO) GO TO 170
            IF (XIH .GE. B(1,I)) GO TO 200
            GO TO 180
 170     IF (XIH .LE. B(2,I)) GO TO 200
 180        IF (HIT) GO TO 190
            HIT = .TRUE.
            H = -H
            GO TO 160
C
C        *** ERROR RETURN...
 190     IRC = I + P
         GO TO 230
C
C        *** RETURN FOR NEW FUNCTION VALUE...
 200     X(I) = XIH
         W(HSAVE) = H
         GO TO 999
C
C     ***  COMPUTE ACTUAL FORWARD DIFFERENCE  ***
C
 210     G(IRC) = (FX - W(FX0)) / W(HSAVE)
         X(IRC) = W(XISAVE)
         GO TO 20
C
C  ***  RESTORE FX AND INDICATE THAT G HAS BEEN COMPUTED  ***
C
 220  IRC = 0
 230  FX = W(FX0)
C
 999  RETURN
C  ***  LAST LINE OF DS3GRD FOLLOWS  ***
      END


module Mod_CaseAdaptive
   use Mod_GeneralCase
   use Mod_caseVariables
   use Mod_DistributedContainer
   use Mod_DC_Driver
   use Mod_DriverInterface
   implicit none

   type(caseVariables), pointer :: c => NULL()
   type(masterVariables), pointer :: m => NULL()
   type(domainVariables), pointer :: d => NULL()
   type(adaptiveVariables), pointer :: ad => NULL()

contains

   subroutine LoopPreRefine(myDC)
      implicit none

      class(DistributedContainer), pointer :: myDC
      class(DriverInterface), pointer :: myDriver => NULL()

      call ExtractDriver(myDC,myDriver)
      call myDriver%PreRefine(c)
   end subroutine

   subroutine LoopRefine(myDC)
      implicit none

      class(DistributedContainer), pointer :: myDC
      class(DriverInterface), pointer :: myDriver => NULL()

      call ExtractDriver(myDC,myDriver)
      call myDriver%Refine(c)
   end subroutine

   subroutine LoopRebalance(myDC)
      implicit none

      class(DistributedContainer), pointer :: myDC
      class(DriverInterface), pointer :: myDriver => NULL()

      call ExtractDriver(myDC,myDriver)
      call myDriver%Rebalance(c)
   end subroutine
end module

subroutine case_Adaptive(a,itask)
   !Deals with the adaptive process at the beginning of each time step
   use typre
   use Mod_GeneralCase
   use Mod_caseVariables
   use def_parame
   use Mod_int2str
   use Mod_Mesh_AR_Interface
   use Mod_Refiners
   use Mod_DistributedContainer
   use Mod_DC_Driver
   use Mod_DriverInterface
   use Mod_CaseAdaptive
   use MPI
   implicit none
   class(GeneralCase), target :: a
   integer(ip) :: itask

   integer(ip) :: nelem
   integer(ip), allocatable :: level(:)
   character(150) :: fil_outpu_dom, fil_postp,fil_postp_graf,extra
   logical :: kfl_DoRebalancing
   type(Mesh_IniData) :: MyIniData
   integer(ip), allocatable :: processor(:)
   integer(ip) :: npoin,npoinLocal
   integer(ip), allocatable :: PointGlobNumber(:),PointProcNumber(:)
   real(rp), pointer :: coord(:,:) => NULL()
   integer(ip) :: iaux,maxmark
   integer(ip) :: ierr

   character(DCHashCharSize) :: DoFirstKeys(1)

   character(150) :: namda

   class(DistributedContainer), pointer :: myDC => NULL()
   class(DriverInterface), pointer      :: myDriver => NULL()

   interface
      subroutine RebalancingCriteria(a,kfl_DoRebalancing)
         use Mod_GeneralCase
         class(GeneralCase), target :: a
         logical :: kfl_DoRebalancing
      end subroutine

      subroutine case_EnsureMaxLevelLimit(a)
         use typre
         use Mod_GeneralCase
         implicit none
         class(GeneralCase), target :: a
      end subroutine

   end interface

   c   => a%caseVars
   m   => a%caseVars%masterVars
   d   => a%caseVars%domainVars
   ad  => a%caseVars%adaptiveVars

   call ad%cpu_adaptive%Tic

   if (itask == 1) then
      !Refiner initializations

      if (ad%kfl_AdaptiveRefinement == 1) then
         call MyIniData%Initialize(d%Mesh)

         !Only one type of adaptive refiner available
         ad%Refiner => IsotropicAdaptiveRefiner_Const()

         call ad%Refiner%SetMPI(m%MPIcomm,m%MPIsize,m%MPIroot,m%MPIrank)
         call ad%Refiner%SetOutputFiles(m%lun_memor,m%lun_outpu)
         call ad%Refiner%Initialize(MyIniData)
         call ad%Refiner%Set_2_1_Balancing(ad%kfl_21Balancing)

         call d%Mesh%InitializeAdaptiveRefinement(ad%Refiner)

      endif
   elseif (itask == 2) then

      if (ad%kfl_AdaptiveRefinement == 1 .and. c%masterVars%istep > ad%AdaptiveDelay) then
         !Refine
         call d%Mesh%GetNelem(nelem)
         call m%MasterMemo%alloc(nelem,ad%RefinerMarkel,'RefinerMarkel','Begste')

         if (ad%RefinementLeader == 'ALLRE') then
            ad%RefinerMarkel = 1
         else
            !Get Refinement Criteria from the Refinement leader
            call a%DriverList%GetFromKey(ad%RefinementLeader,myDC)
            if (.not. associated(myDC)) call runend('Adaptive: RefinementLeader not found')
            call ExtractDriver(myDC,myDriver)
            !This sets the RefinerMarkel array, we should change the interface (not the full c)
            call myDriver%GetRefinementCriteria(c)
            !Limit the maximum refinement level if required
            call case_EnsureMaxLevelLimit(a)
         endif

         !Do not refine if there is nothing to do
         iaux = maxval(abs(ad%RefinerMarkel))
         call MPI_ALLREDUCE(iaux,maxmark,1,MPI_INTEGER4,MPI_MAX,m%MPIcomm,ierr)
         if (maxmark == 0) then
            call m%MasterMemo%dealloc(nelem,ad%RefinerMarkel,'RefinerMarkel','Begste')
            return
         endif

         !Continue with the preparation of the adaptive refinement process
         call ad%Refiner%PrepareOldExternalBoundariesInfoToKeep
         call d%Mesh%MatchOldBoundariesToRefiner

         !Prerefine
         call a%DriverList%LoopList(LoopPreRefine)

         !Coord for setting tetra variations
         call d%Mesh%GetCoord(coord)
         call ad%Refiner%SetCoordArray(coord)

         !Refine the refiner and the mesh
         call ad%Refiner%Refine(ad%RefinerMarkel)
         call d%Mesh%Refine('Refine')

         call m%MasterMemo%dealloc(nelem,ad%RefinerMarkel,'RefinerMarkel','Begste')

         if (ad%UpdateIO) then
            if (mod(m%istep,ad%UpdateFreq) == 0) then
               call a%SetupIO(1)
               call a%SetupIO(0)
            end if
         end if

         !For each driver, do their adaptive refinement process
         !ALE needs to be done first
         DoFirstKeys(1) = 'ALEPR'
         call a%DriverList%LoopList(LoopRefine,DoFirstKeys(1:1))

         !Load Rebalancing Criteria
         call RebalancingCriteria(a,kfl_DoRebalancing)

         if (kfl_DoRebalancing .eqv. .true.) then

            call ad%Refiner%PrepareOldExternalBoundariesInfoToKeep
            call d%Mesh%MatchOldBoundariesToRefiner
            call d%Mesh%GetNpoin(npoin)

            call m%MasterMemo%alloc(npoin,PointGlobNumber,'PointGlobNumber','Adaptive')
            call m%MasterMemo%alloc(npoin,PointProcNumber,'PointProcNumber','Adaptive')

            call d%Mesh%ComputeRebalancingNumbering(PointGlobNumber,PointProcNumber)
            call ad%Refiner%SetRebalancingNumbering(PointGlobNumber,PointProcNumber)

            call m%MasterMemo%dealloc(npoin,PointGlobNumber,'PointGlobNumber','Adaptive')
            call m%MasterMemo%dealloc(npoin,PointProcNumber,'PointProcNumber','Adaptive')

            call ad%Refiner%LoadRebalance
            call d%Mesh%Refine('Rebalance')

            !For each driver, do the load rebalancing process
            !ALE needs to be done first
            DoFirstKeys(1) = 'ALEPR'
            call a%DriverList%LoopList(LoopRebalance,DoFirstKeys(1:1))
         endif

         !For each driver, reset the pointers for the outChannel, so that anybody can find them
         call a%DriverList%GetFirst(myDC)
         do while (associated(myDC))
            call ExtractDriver(myDC,myDriver)
            call myDriver%SetOutChannels('UPDATE')
            call a%DriverList%GetNext(myDC)
         enddo

         !PostProcessing
         !close postprocess file and open a new file
         call m%FilePostpr%ClosePostFile
         call m%FilePostpr%CloseGrafFile
         m%meshCounter = m%meshCounter+1
         fil_postp_graf = trim(m%PostProcessFolder)//'/'//adjustl(trim(m%namda))//adjustl(trim(int2str(m%MPIrank)))
         fil_postp_graf = trim(fil_postp_graf)//'mesh'//adjustl(trim(int2str(m%meshCounter)))//'.post.grf'
         call m%FilePostpr%OpenPostFile(m%PostProcessFolder,m%namda,m%meshCounter)
         call m%FilePostpr%OpenGrafFile(fil_postp_graf)
         call m%FilePostpr%Postpr(d%Mesh)

      endif

   elseif (itask == 100) then
      !Deallocate Refiner
      if (ad%kfl_AdaptiveRefinement == 1) then
         call ad%Refiner%Dealloc
      endif
   elseif (itask == 101) then
      if (ad%kfl_AdaptiveRefinement == 1) then
         !Deallocate it
         deallocate(ad%Refiner)
      endif
   endif

   call ad%cpu_adaptive%Toc

contains

end subroutine

subroutine RebalancingCriteria(a,kfl_DoRebalancing)
   use typre
   use Mod_CaseVariables
   use Mod_GeneralCase
   use MPI
   implicit none
   class(GeneralCase), target :: a
   logical :: kfl_DoRebalancing

   integer(ip) :: npoinLocal,maxnpoinLocal,minnpoinLocal,gnpoin
   integer :: ierr
   real(rp) :: ratio
   real(rp) :: optimumnpoin

   type(domainVariables), pointer :: d => NULL()
   type(masterVariables), pointer :: m => NULL()
   type(adaptiveVariables), pointer :: ad => NULL()

   d => a%caseVars%domainVars
   m => a%caseVars%masterVars
   ad => a%caseVars%adaptiveVars

   kfl_DoRebalancing = .false.

   call d%Mesh%GetNpoinLocal(npoinLocal)
   call d%Mesh%GetGnpoin(gnpoin)

   optimumnpoin = real(gnpoin)/m%MPIsize
   call MPI_REDUCE( npoinLocal, maxnpoinLocal, 1, MPI_INTEGER4, MPI_MAX, m%MPIroot,m%MPIcomm, ierr )

   if (m%MPIrank == m%MPIroot) then
      ratio = real(maxnpoinLocal)/optimumnpoin
      if (ratio > ad%RefinerRebalancingRatio) kfl_DoRebalancing = .true.
   endif

   CALL MPI_BCAST(kfl_DoRebalancing, 1, MPI_LOGICAL, m%MPIroot, m%MPIcomm, ierr)
end subroutine

subroutine case_EnsureMaxLevelLimit(a)
   use typre
   use Mod_CaseVariables
   use Mod_AdaptiveVariables
   use Mod_GeneralCase
   use Mod_Element
   implicit none
   class(GeneralCase), target :: a

   integer(ip) :: npoin
   integer(ip), allocatable :: level(:)
   class(FiniteElement), pointer :: e => NULL()

   type(caseVariables), pointer :: c => NULL()
   type(domainVariables), pointer :: d => NULL()
   type(masterVariables), pointer :: m => NULL()
   type(adaptiveVariables), pointer :: ad => NULL()

   integer(ip) :: ielem,nelem,maxlevel
   integer(ip) :: CurrentAdaptiveMaxLevel

   c => a%caseVars
   d => a%caseVars%domainVars
   m => a%caseVars%masterVars
   ad => a%caseVars%adaptiveVars

   currentAdaptiveMaxLevel = ad%RefinerMaxLevel
   if (currentAdaptiveMaxlevel == 0) currentAdaptiveMaxLevel = -1

   if (ad%ProgressiveMaxLevel > 0) then
      currentAdaptiveMaxLevel = min(currentAdaptiveMaxLevel,m%istep/ad%ProgressiveMaxLevel)
   endif

   !if (currentAdaptiveMaxLevel > 0) then
      call d%Mesh%GetNpoin(npoin)
      call m%MasterMemo%alloc(npoin,level,'level','ApplyErrorCriteria')
      call ad%Refiner%GetLevel(level)

      call d%Mesh%ElementAlloc(e,m%MasterMemo,'DefaultRule','nsm_EnditeElmope')

      call d%Mesh%GetNelem(nelem)
      do ielem = 1,nelem
         !Load Element
         call d%Mesh%ElementLoad(ielem,e)
         maxlevel = maxval(level(e%lnods(1:e%pnode)))

         if ((currentAdaptiveMaxLevel > -1) .and. (maxlevel >= currentAdaptiveMaxLevel) .and. (ad%RefinerMarkel(ielem) == 1)) ad%RefinerMarkel(ielem) = 0
         if (ad%RefinerMarkel(ielem) == -1 .and. (maxlevel == 0)) ad%RefinerMarkel(ielem) = 0

      enddo

      call m%MasterMemo%dealloc(npoin,level,'level','ApplyErrorCriteria')
      call d%Mesh%ElementDeAlloc(e,m%MasterMemo,'DefaultRule','nsm_EnditeElmope')

   !endif

end subroutine


c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  function energy  --  evaluates energy terms and total  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "energy" calls the subroutines to calculate the potential
c     energy terms and sums up to form the total energy
c
c
      function energy ()
      implicit none
      include 'sizes.i'
      include 'bound.i'
      include 'cutoff.i'
      include 'energi.i'
      include 'iounit.i'
      include 'potent.i'
      include 'rigid.i'
      include 'vdwpot.i'
      real*8 energy
      real*8 cutoff
c
c
c     zero out each of the potential energy components
c
      eb = 0.0d0
      ea = 0.0d0
      eba = 0.0d0
      eub = 0.0d0
      eaa = 0.0d0
      eopb = 0.0d0
      eopd = 0.0d0
      eid = 0.0d0
      eit = 0.0d0
      et = 0.0d0
      ept = 0.0d0
      ebt = 0.0d0
      ett = 0.0d0
      ev = 0.0d0
      ec = 0.0d0
      ecd = 0.0d0
      ed = 0.0d0
      em = 0.0d0
      ep = 0.0d0
      er = 0.0d0
      es = 0.0d0
      elf = 0.0d0
      eg = 0.0d0
      ex = 0.0d0
c
c     maintain any periodic boundary conditions
c
      if (use_bounds .and. .not.use_rigid)  call bounds
c
c     update the pairwise interaction neighbor lists
c
      if (use_list)  call nblist
c
c     remove any previous use of the replicates method
c
      cutoff = 0.0d0
      call replica (cutoff)
c
c     many implicit solvation models require Born radii
c
      if (use_born)  call born
c
c     alter bond and torsion constants for pisystem
c
      if (use_orbit)  call picalc
c
c     call the local geometry energy component routines
c
      if (use_bond)  call ebond
      if (use_angle)  call eangle
      if (use_strbnd)  call estrbnd
      if (use_urey)  call eurey
      if (use_angang)  call eangang
      if (use_opbend)  call eopbend
      if (use_opdist)  call eopdist
      if (use_improp)  call eimprop
      if (use_imptor)  call eimptor
      if (use_tors)  call etors
      if (use_pitors)  call epitors
      if (use_strtor)  call estrtor
      if (use_tortor)  call etortor
c
c     call the van der Waals energy component routines
c
      if (use_vdw) then
         if (vdwtyp .eq. 'LENNARD-JONES')  call elj
         if (vdwtyp .eq. 'BUCKINGHAM')  call ebuck
         if (vdwtyp .eq. 'MM3-HBOND')  call emm3hb
         if (vdwtyp .eq. 'BUFFERED-14-7')  call ehal
         if (vdwtyp .eq. 'GAUSSIAN')  call egauss
      end if
c
c     call the electrostatic energy component routines
c
      if (use_charge)  call echarge
      if (use_chgdpl)  call echgdpl
      if (use_dipole)  call edipole
      if (use_mpole .or. use_polar)  call empole
      if (use_rxnfld)  call erxnfld
c
c     call any miscellaneous energy component routines
c
      if (use_solv)  call esolv
      if (use_geom)  call egeom
      if (use_metal)  call emetal
      if (use_extra)  call extra
c
c     sum up to give the total potential energy
c
      esum = eb + ea + eba + eub + eaa + eopb + eopd + eid + eit
     &          + et + ept + ebt + ett + ev + ec + ecd + ed + em
     &          + ep + er + es + elf + eg + ex
      energy = esum
c
c     check for an illegal value for the total energy
c
      if (isnan(esum)) then
         write (iout,10)
   10    format (/,' ENERGY  --  Illegal Value for the Total',
     &              ' Potential Energy')
         call fatal
      end if
      return
      end


! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
! H0 X
! H0 X   libAtoms+QUIP: atomistic simulation library
! H0 X
! H0 X   Portions of this code were written by
! H0 X     Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode,
! H0 X     Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield.
! H0 X
! H0 X   Copyright 2006-2010.
! H0 X
! H0 X   These portions of the source code are released under the GNU General
! H0 X   Public License, version 2, http://www.gnu.org/copyleft/gpl.html
! H0 X
! H0 X   If you would like to license the source code under different terms,
! H0 X   please contact Gabor Csanyi, gabor@csanyi.net
! H0 X
! H0 X   Portions of this code were written by Noam Bernstein as part of
! H0 X   his employment for the U.S. Government, and are not subject
! H0 X   to copyright in the USA.
! H0 X
! H0 X
! H0 X   When using this software, please cite the following reference:
! H0 X
! H0 X   http://www.libatoms.org
! H0 X
! H0 X  Additional contributions by
! H0 X    Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras
! H0 X
! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

!X
!X  Barostat module
!X
!% This module contains the implementations for all the barostats available
!% in libAtoms: Langevin thermalized Hoover
!%
!% With $Q > 0$, use adaptive (aka open) Langevin, from Jones \& Leimkuhler
!% preprint ``Adaptive Stochastic Methods for Nonequilibrium Sampling"
!X
!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

module barostat_module

  use system_module
  use units_module
  use linearalgebra_module
  use atoms_module

  implicit none
  private
  public :: barostat, initialise, finalise, print, update_barostat, set_degrees_of_freedom, barostat_mass
  public :: BAROSTAT_NONE, BAROSTAT_HOOVER_LANGEVIN
  public :: barostat_pre_vel1, barostat_post_vel1_pre_pos, barostat_post_pos_pre_calc, barostat_post_calc_pre_vel2, barostat_post_vel2

  real(dp), parameter :: BAROSTAT_MIN_TEMP = 1.0_dp

  integer, parameter :: BAROSTAT_NONE                 = 0, &
                        BAROSTAT_HOOVER_LANGEVIN      = 1

  !% Langevin barostat - fluctuation/dissipation ---
  !% originally implemented for hydrostatic strain using
  !% EOM from Quigley, D. and Probert, M.I.J., \emph{J. Chem. Phys.},
  !% {\bfseries 120} 11432
  !% rediscretized by Noam Bernstein based on ideas from and discussion
  !% with B. Leimkuhler.
  !% modified for arbitrary strain based on (but not exactly using)
  !% formulation in E. Tadmor and R. Miller Modeling Materials: Continuum, Atomistic and Multiscale
  !% Techniques (Cambridge University Press, 2011). Chap 9.5.  Their
  !% definition of stress (factors of $F$, $F^T$, $J$, and $F^{-T}$) for finite strain is
  !% optionally used, but certain terms in EOM are excluded, and their discretization
  !% is entirely ignored.

  type barostat

     integer  :: type  = BAROSTAT_NONE     !% One of the types listed above
     real(dp) :: gamma_epsilon = 0.0_dp   !% Friction coefficient for Langevin part
     real(dp) :: T = -1.0_dp   !% Temperature for Langevin part
     real(dp) :: Ndof  = 0.0_dp   !% The number of degrees of freedom of atoms attached to this barostat
     real(dp) :: stress_ext(3,3) = 0.0_dp       !% External applied stress
     real(dp) :: W_epsilon = 0.0_dp     !% Fictious cell mass in Langevin NPT
     real(dp) :: epsilon_v(3,3) = 0.0_dp !% Velocity of deformation gradient for barostat
     real(dp) :: epsilon_f(3,3) = 0.0_dp !% Force on deformation gradient
     real(dp) :: epsilon_r(3,3) = reshape( (/ 1.0_dp, 0.0_dp, 0.0_dp,    0.0_dp, 1.0_dp, 0.0_dp,    0.0_dp, 0.0_dp, 1.0_dp /), (/ 3, 3 /) ) !% Value of deformation gradient
     logical :: hydrostatic_strain = .true., diagonal_strain = .true., finite_strain_formulation=.false.

     real(dp) :: lattice0(3,3), lattice0_inv(3,3), F_tmp_norm
     logical :: lattice0_initialised = .false.

  end type barostat

  interface initialise
     module procedure barostat_initialise
  end interface initialise

  interface finalise
     module procedure barostat_finalise
  end interface finalise

  interface assignment(=)
     module procedure barostat_assignment
  end interface assignment(=)

  interface print
     module procedure barostat_print
  end interface

  interface update_barostat
     module procedure barostat_update_barostat
  end interface update_barostat

  interface set_degrees_of_freedom
     module procedure set_degrees_of_freedom_int, set_degrees_of_freedom_real
  end interface set_degrees_of_freedom

  interface barostat_mass
     module procedure barostat_mass_int, barostat_mass_real
  end interface barostat_mass

contains

  !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
  !X
  !X INITIALISE / FINALISE
  !X
  !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

  subroutine barostat_initialise(this,type,p_ext,stress_ext,hydrostatic_strain,diagonal_strain,finite_strain_formulation,deformation_grad,cell_volume,W_epsilon,Ndof,gamma_epsilon,T,W_epsilon_factor, thermalise)

    type(barostat),   intent(inout) :: this
    integer,            intent(in)    :: type
    real(dp), optional, intent(in)    :: p_ext
    real(dp), optional, intent(in)    :: stress_ext(3,3)
    logical, optional, intent(in)     :: hydrostatic_strain, diagonal_strain
    logical, optional, intent(in)     :: finite_strain_formulation
    real(dp), optional, intent(in)    :: deformation_grad(3,3)
    real(dp), optional, intent(in)    :: cell_volume
    real(dp), optional, intent(in)    :: W_epsilon
    real(dp), optional, intent(in)    :: Ndof
    real(dp), optional, intent(in)    :: gamma_epsilon
    real(dp), optional, intent(in)    :: T
    real(dp), optional, intent(in)    :: W_epsilon_factor
    logical, optional, intent(in)     :: thermalise

    real(dp) :: use_T
    logical :: use_thermalise

    if (type /= BAROSTAT_NONE .and. .not.present(p_ext) .and. .not. present(stress_ext)) &
         call system_abort('barostat_initialise: p_ext or stress_ext must be specified when turning on a barostat')

    if (present(p_ext) .and. present(stress_ext)) &
         call system_abort('barostat_initialise: got both p_ext and stress_ext')

    this%type = type
    this%epsilon_v = 0.0_dp
    this%epsilon_f = 0.0_dp
    if (present(deformation_grad)) then
      this%epsilon_r = deformation_grad
    else
      this%epsilon_r = 0.0_dp; call add_identity(this%epsilon_r)
    endif
    this%lattice0_initialised = .false.

    select case(this%type)

    case(BAROSTAT_NONE)

       this%stress_ext = 0.0_dp
       this%gamma_epsilon = 0.0_dp
       this%W_epsilon = 0.0_dp
       this%Ndof = 0.0_dp
       this%T = -1.0_dp

    case(BAROSTAT_HOOVER_LANGEVIN)

       if (.not.present(p_ext) .and. .not. present(stress_ext)) call system_abort('barostat initialise: p_ext or stress_ext is required for Hoover-Langevin barostat')
       if (present(p_ext) .and. present(stress_ext)) call system_abort('barostat initialise: p_ext and stress_ext conflict for Hoover-Langevin barostat')
       if (.not.present(gamma_epsilon)) call system_abort('barostat initialise: gamma_epsilon is required for Hoover-Langevin barostat')
       if (gamma_epsilon <= 0.0_dp) call system_abort('barostat initialise: gamma_epsilon must be > 0.0 for Hoover-Langevin')
       if (.not.present(Ndof)) call system_abort('barostat initialise: Ndof is required for Hoover-Langevin barostat')
       if (Ndof <= 0.0_dp) call system_abort('barostat initialise: Ndof must be > 0.0 for Hoover-Langevin')

       if (.not.present(W_epsilon) .and. .not. present(cell_volume)) call system_abort('barostat initialise: W_epsilon or cell_volume is required for Hoover-Langevin barostat')
       if (present(W_epsilon)) then
	  if (W_epsilon <= 0.0_dp) call system_abort('barostat initialise: W must be > 0.0 for Hoover-Langevin')
       endif
       if (present(cell_volume)) then
	  if (cell_volume <= 0.0_dp) call system_abort('barostat initialise: cell_volume must be > 0.0 for Hoover-Langevin')
       endif

       if (present(p_ext)) then ! S = - p_ext I
	  this%stress_ext = 0.0_dp
	  call add_identity(this%stress_ext)
	  this%stress_ext = -p_ext * this%stress_ext
       else
	  this%stress_ext = stress_ext
       endif

       if (present(hydrostatic_strain)) this%hydrostatic_strain = hydrostatic_strain
       if (present(diagonal_strain)) this%diagonal_strain = diagonal_strain
       if (present(finite_strain_formulation)) this%finite_strain_formulation = finite_strain_formulation

       this%Ndof = Ndof
       if (present(W_epsilon)) then
	  this%W_epsilon = W_epsilon
       else
	  this%W_epsilon = barostat_mass(maxval(abs(this%stress_ext)), cell_volume, Ndof, gamma_epsilon, T, W_epsilon_factor)
       endif
       use_T = optional_default(-1.0_dp, T)
       use_thermalise = optional_default(.true., thermalise)
       if (use_thermalise .and. use_T > 0.0_dp) then
	 this%gamma_epsilon = gamma_epsilon
       else
	 this%gamma_epsilon = 0.0_dp
       endif
       this%T = use_T

    case default
       call system_abort("Invalid barostat type " // type)

    end select

  end subroutine barostat_initialise

  subroutine barostat_finalise(this)

    type(barostat), intent(inout) :: this

    this%type  = BAROSTAT_NONE
    this%gamma_epsilon = 0.0_dp
    this%stress_ext     = 0.0_dp
    this%hydrostatic_strain     = .true.
    this%diagonal_strain     = .true.
    this%finite_strain_formulation     = .false.
    this%Ndof  = 0.0_dp
    this%W_epsilon = 0.0_dp
    this%epsilon_v = 0.0_dp
    this%epsilon_f = 0.0_dp
    this%epsilon_r = 0.0_dp; call add_identity(this%epsilon_r)
    this%T = -1.0_dp
    this%lattice0_initialised = .false.

  end subroutine barostat_finalise

  subroutine barostat_assignment(to,from)

    type(barostat), intent(out) :: to
    type(barostat), intent(in)  :: from

    to%type  = from%type
    to%gamma_epsilon = from%gamma_epsilon
    to%stress_ext     = from%stress_ext
    to%hydrostatic_strain     = from%hydrostatic_strain
    to%diagonal_strain     = from%diagonal_strain
    to%finite_strain_formulation     = from%finite_strain_formulation
    to%W_epsilon = from%W_epsilon
    to%epsilon_v = from%epsilon_v
    to%epsilon_f = from%epsilon_f
    to%epsilon_r = from%epsilon_r
    to%T = from%T

  end subroutine barostat_assignment

  subroutine barostat_update_barostat(this,p_ext,stress_ext,hydrostatic_strain,diagonal_strain,finite_strain_formulation,W_epsilon,T)

    type(barostat),   intent(inout) :: this
    real(dp), optional, intent(in)    :: p_ext
    real(dp), optional, intent(in)    :: stress_ext(3,3)
    logical, optional, intent(in)    :: hydrostatic_strain, diagonal_strain
    logical, optional, intent(in)    :: finite_strain_formulation
    real(dp), optional, intent(in)    :: W_epsilon
    real(dp), optional, intent(in)    :: T

    if( present(p_ext) .and. present(stress_ext)) call system_abort("barostat_update_barostat: got both p_ext and stress_ext, conflict")
    if( present(p_ext) ) then
      this%stress_ext = 0.0_dp
      call add_identity(this%stress_ext)
      this%stress_ext = -p_ext * this%stress_ext
    endif
    if( present(stress_ext) ) this%stress_ext = stress_ext
    if( present(hydrostatic_strain) ) this%hydrostatic_strain = hydrostatic_strain
    if( present(diagonal_strain) ) this%diagonal_strain = diagonal_strain
    if( present(finite_strain_formulation) ) this%finite_strain_formulation = finite_strain_formulation
    if( present(W_epsilon) ) this%W_epsilon = W_epsilon
    if( present(T) ) this%T = T

  endsubroutine barostat_update_barostat

  !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
  !X
  !X PRINTING
  !X
  !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

  subroutine barostat_print(this,file)

    type(barostat),           intent(in) :: this
    type(inoutput), optional, intent(in) :: file

    select case(this%type)

       case(BAROSTAT_NONE)
	  call print('Barostat off',file=file)

       case(BAROSTAT_HOOVER_LANGEVIN)
	  call print('Hoover-Langevin, stress_ext = '// &
	  round(this%stress_ext(1,1)/EV_A3_IN_GPA,5)//' '// &
	  round(this%stress_ext(1,2)/EV_A3_IN_GPA,5)//' '// &
	  round(this%stress_ext(1,3)/EV_A3_IN_GPA,5)//' '// &
	  round(this%stress_ext(2,1)/EV_A3_IN_GPA,5)//' '// &
	  round(this%stress_ext(2,2)/EV_A3_IN_GPA,5)//' '// &
	  round(this%stress_ext(2,3)/EV_A3_IN_GPA,5)//' '// &
	  round(this%stress_ext(3,1)/EV_A3_IN_GPA,5)//' '// &
	  round(this%stress_ext(3,2)/EV_A3_IN_GPA,5)//' '// &
	  round(this%stress_ext(3,3)/EV_A3_IN_GPA,5)//' GPa , hydrostatic_strain = '//this%hydrostatic_strain//&
	    ' diagonal_strain = '//this%diagonal_strain//' finite_strain_formulation = '//this%finite_strain_formulation//&
	    ' gamma_epsilon = '//round(this%gamma_epsilon,5)//' fs^-1, '// &
	    ' W_epsilon = '//round(this%W_epsilon,5)//' eV/fs, T = '//round(this%T,2)//' K, Ndof = '// round(this%Ndof,1),file=file)

    end select

  end subroutine barostat_print

  !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
  !X
  !X SETTING Ndof
  !X
  !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

  subroutine set_degrees_of_freedom_int(this,Ndof)

    type(barostat), intent(inout) :: this
    integer,          intent(in)    :: Ndof

    this%Ndof = real(Ndof,dp)

  end subroutine set_degrees_of_freedom_int

  subroutine set_degrees_of_freedom_real(this,Ndof)

    type(barostat), intent(inout) :: this
    real(dp),         intent(in)    :: Ndof

    this%Ndof = Ndof

  end subroutine set_degrees_of_freedom_real

  !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
  !X
  !X CHOOSING NOSE-HOOVER(-LANGEVIN) MASS
  !X
  !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

  pure function barostat_mass_int(p_ext, cell_volume, Ndof, gamma_epsilon, T, W_epsilon_factor) result(W_epsilon)

    real(dp), intent(in) :: p_ext, cell_volume
    integer,  intent(in) :: Ndof
    real(dp), intent(in) :: gamma_epsilon
    real(dp), intent(in), optional   :: T
    real(dp), intent(in), optional   :: W_epsilon_factor
    real(dp) :: W_epsilon ! result

    W_epsilon = barostat_mass_real(p_ext, cell_volume, real(Ndof,dp), gamma_epsilon, T, W_epsilon_factor)

  end function barostat_mass_int

  pure function barostat_mass_real(p_ext, cell_volume, Ndof, gamma_epsilon, T, W_epsilon_factor) result(W_epsilon)

    real(dp), intent(in) :: p_ext, cell_volume
    real(dp), intent(in) :: Ndof
    real(dp), intent(in) :: gamma_epsilon
    real(dp), intent(in), optional   :: T
    real(dp), intent(in), optional   :: W_epsilon_factor
    real(dp) :: W_epsilon ! result

    real(dp) :: use_T, use_W_epsilon_factor

    use_T = optional_default(BAROSTAT_MIN_TEMP, T)
    if (use_T <= 0.0_dp) use_T = BAROSTAT_MIN_TEMP

    use_W_epsilon_factor=optional_default(1.0_dp, W_epsilon_factor)

    W_epsilon = use_W_epsilon_factor*max( 9.0_dp*abs(p_ext)*cell_volume/((gamma_epsilon*2.0_dp*PI)**2), &
		     (Ndof+3.0_dp)*BOLTZMANN_K*use_T/((gamma_epsilon*2.0_dp*PI)**2) )

  end function barostat_mass_real

  !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
  !X
  !X BAROSTAT ROUTINES
  !X
  !X These routines interleave the usual velocity Verlet steps and thermostat steps
  !X should modify the velocities accelerations, and positions as required:
  !X
  !X advance_verlet1
  !X   00 (barostat_pre_vel1) *
  !X   10 (thermostat_pre_vel1) *
  !X   20 v(t+dt/2) = v(t) + a(t)dt/2
  !X   30 (thermostat_post_vel1_pre_pos)
  !X   40 r(t+dt) = r(t) + v(t+dt/2)dt
  !X   50 (thermostat_post_pos_pre_calc)
  !X   60 (barostat_post_pos_pre_calc) *
  !X calc F, virial
  !X advance_verlet2
  !X   70 (thermostat_post_calc_pre_vel2) *
  !X   80 v(t+dt) = v(t+dt/2) + a(t+dt)dt/2
  !X   90 (thermostat_post_vel2) *
  !X   100 (barostat_post_vel2) *
  !X
  !X * marks routines that are needed in the refactored barostat/thermostat plan
  !X
  !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

  subroutine barostat_pre_vel1(this,at,dt,virial)

    type(barostat), intent(inout) :: this
    type(atoms),      intent(inout) :: at
    real(dp),         intent(in)    :: dt
    real(dp), dimension(3,3), optional, intent(in) :: virial

    real(dp) :: vel_decay(3,3), pos_scale(3,3), lattice_p(3,3), F_inv(3,3), F_tmp(3,3)

    select case(this%type)

       !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
       !X
       !X HOOVER-LANGEVIN
       !X
       !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    case(BAROSTAT_HOOVER_LANGEVIN)
       !TIME_PROPAG_TEX 00
       !TIME_PROPAG_TEX 00 {\color {blue}
       !TIME_PROPAG_TEX 00 before all Verlet and thermostat steps (barostat\_pre\_vel1)
       !TIME_PROPAG_TEX 00
       !TIME_PROPAG_TEX 00 $$ \epsilon_v = \epsilon_v \exp\left( -(\tau/2) \gamma_\epsilon \epsilon_r^{-1}\right)^T$$
       !TIME_PROPAG_TEX 00 $$ \epsilon_v = \epsilon_v +  (\tau/2) \epsilon_f/W_\epsilon $$
       !TIME_PROPAG_TEX 00 $$ v = \exp \left(  -(\tau/2) (1 + 3/N_d) \epsilon_v \right) v $$
       !TIME_PROPAG_TEX 00 $$ (r,h) = \exp\left( (\tau/2) \epsilon_v \right) (r,h) $$
       !TIME_PROPAG_TEX 00 }
       !TIME_PROPAG_TEX 00

       if (.not. present(virial)) call system_abort("barostat_pre_vel1 needs virial")

       if (.not. this%lattice0_initialised) then
	  this%lattice0_initialised = .true.
	  this%lattice0 = at%lattice
	  call matrix3x3_inverse(this%lattice0, this%lattice0_inv)
	  this%F_tmp_norm = 0.0_dp
       endif

       ! half step epsilon_v drag
       if (this%finite_strain_formulation) then
	  call matrix3x3_inverse(this%epsilon_r, F_inv)
	  vel_decay = transpose(matrix_exp(-0.5_dp*dt*this%gamma_epsilon*F_inv))
	  vel_decay = 0.5_dp*(vel_decay + transpose(vel_decay))
	  this%epsilon_v = this%epsilon_v .mult. vel_decay
       else
	  this%epsilon_v = this%epsilon_v * exp(-0.5_dp*dt*this%gamma_epsilon)
       endif
       ! half step epsilon_v force (from last step) parts
       this%epsilon_v = this%epsilon_v + 0.5_dp*dt*this%epsilon_f/this%W_epsilon

       ! half step barostat drag part of v
       vel_decay = matrix_exp(-0.5_dp*dt*((1.0_dp + 3.0_dp/this%Ndof)*this%epsilon_v))
       vel_decay = 0.5_dp*(vel_decay + transpose(vel_decay))
       at%velo = vel_decay .mult. at%velo

       ! half step position affine defomration
       pos_scale = matrix_exp(0.5_dp*dt*this%epsilon_v)
       pos_scale = 0.5_dp*(pos_scale + transpose(pos_scale))
       lattice_p = pos_scale .mult. at%lattice
       ! remove any rotation from new lattice
       F_tmp = lattice_p .mult. this%lattice0_inv
       F_tmp = 0.5_dp*(F_tmp + transpose(F_tmp))
       if (abs(deviation_from_identity(F_tmp) - this%F_tmp_norm) > 5.0e-2) then
	 call print_warning("barostat transformation projecting away rotations is very different from previous one.  Did the lattice change?")
       endif
       this%F_tmp_norm = deviation_from_identity(F_tmp)
       lattice_p = F_tmp .mult. this%lattice0
       call set_lattice(at, lattice_p, scale_positions=.true.)

    end select

  end subroutine barostat_pre_vel1

  subroutine barostat_post_vel1_pre_pos(this,at,dt,virial)

    type(barostat), intent(inout) :: this
    type(atoms),      intent(inout) :: at
    real(dp),         intent(in)    :: dt
    real(dp), dimension(3,3), optional, intent(in) :: virial

  end subroutine barostat_post_vel1_pre_pos

  subroutine barostat_post_pos_pre_calc(this,at,dt,virial)

    type(barostat), intent(inout) :: this
    type(atoms),      intent(inout) :: at
    real(dp),         intent(in)    :: dt
    real(dp), dimension(3,3), optional, intent(in) :: virial

    real(dp) :: pos_scale(3,3), lattice_p(3,3), F_tmp(3,3)

    select case(this%type)

      case(BAROSTAT_HOOVER_LANGEVIN)
        !TIME_PROPAG_TEX 60
        !TIME_PROPAG_TEX 60 {\color {blue}
        !TIME_PROPAG_TEX 60 after Verlet pos step, before force calc (barostat\_post\_pos\_pre\_calc)
        !TIME_PROPAG_TEX 60
        !TIME_PROPAG_TEX 60 $$ (r,h) = \exp\left( (\tau/2) \epsilon_v \right) (r,h) $$
        !TIME_PROPAG_TEX 60 }
        !TIME_PROPAG_TEX 60
        if (.not. present(virial)) call system_abort("barostat_post_pos_pre_calc needs virial")

        ! half step position affine defomration
        pos_scale = matrix_exp(0.5_dp*dt*this%epsilon_v)
        pos_scale = 0.5_dp*(pos_scale + transpose(pos_scale))
        lattice_p = pos_scale .mult. at%lattice
        ! remove any rotation from new lattice
        F_tmp = lattice_p .mult. this%lattice0_inv
        F_tmp = 0.5_dp*(F_tmp + transpose(F_tmp))
        if (abs(deviation_from_identity(F_tmp) - this%F_tmp_norm) > 5.0e-2) then
	   call print_warning("barostat transformation projecting away rotations is very different from previous one.  Did the lattice change?")
        endif
        this%F_tmp_norm = deviation_from_identity(F_tmp)
        lattice_p = F_tmp .mult. this%lattice0
        call set_lattice(at, lattice_p, scale_positions=.true.)

    end select

  end subroutine barostat_post_pos_pre_calc

  function deviation_from_identity(a)
     real(dp), intent(in) :: a(:, :)
     real(dp) :: deviation_from_identity

     integer :: i, j

     deviation_from_identity = 0.0_dp
     do i=1, size(a, 1)
     do j=1, size(a, 2)
       if (i == j) then
	  deviation_from_identity = deviation_from_identity + (a(i,j)-1.0_dp)**2
       else
	  deviation_from_identity = deviation_from_identity + (a(i,j))**2
       endif
     end do
     end do

     deviation_from_identity = sqrt(deviation_from_identity)

  end function deviation_from_identity

  subroutine barostat_post_calc_pre_vel2(this,at,dt,virial)

    type(barostat), intent(inout) :: this
    type(atoms),      intent(inout) :: at
    real(dp),         intent(in)    :: dt
    real(dp), dimension(3,3), optional, intent(in) :: virial

  end subroutine barostat_post_calc_pre_vel2

  subroutine barostat_post_vel2(this,at,dt,virial)

    type(barostat), intent(inout) :: this
    type(atoms),      intent(inout) :: at
    real(dp),         intent(in)    :: dt
    real(dp), dimension(3,3), optional, intent(in) :: virial

    integer :: i, j
    real(dp) :: vel_decay(3,3), volume_p, rand_f_cell(3,3), kinetic_virial(3,3), F_det, F_T_inv(3,3), F_inv(3,3), epsilon_f_hydrostatic
    real(dp) :: rand_f_scale

    select case(this%type)

    case(BAROSTAT_HOOVER_LANGEVIN)
       !TIME_PROPAG_TEX 100
       !TIME_PROPAG_TEX 100 {\color {blue}
       !TIME_PROPAG_TEX 100 after all Verlet and thermostat steps (barostat\_post\_vel2)
       !TIME_PROPAG_TEX 100
       !TIME_PROPAG_TEX 100 $$ v = \exp \left(  -(\tau/2) (1 + 3/N_d) \epsilon_v \right) v $$
       !TIME_PROPAG_TEX 100 $$ \epsilon_r = \epsilon_r + \tau \epsilon_v $$
       !TIME_PROPAG_TEX 100 $r.v.$ is symmetric matrix, normal distribution entries, variance 3 on diagonal and 6 off diagonal
       !TIME_PROPAG_TEX 100 \begin{eqnarray*}
       !TIME_PROPAG_TEX 100 \epsilon_f  & = & \left[ 3 \left( \mathrm{vir} + \sum_i m_i v_i \otimes v_i +
       !TIME_PROPAG_TEX 100                                 3 V \epsilon_r \sigma \epsilon_r^T / \left|\epsilon_r\right|  +
       !TIME_PROPAG_TEX 100                  3/N_d \sum_i m_i  v_i \otimes v_i  \right) + \right.
       !TIME_PROPAG_TEX 100             \\  &  & \sqrt{2 k_B T \gamma_\epsilon W_\epsilon/\tau} r.v. \bigg] F^{-T}
       !TIME_PROPAG_TEX 100 \end{eqnarray*}
       !TIME_PROPAG_TEX 100 $$ \epsilon_v = \epsilon_v +  (\tau/2) \epsilon_f/W_\epsilon $$
       !TIME_PROPAG_TEX 100 $$ \epsilon_v = \epsilon_v \exp\left( -(\tau/2) \gamma_\epsilon \epsilon_r^{-1}\right)^T$$
       !TIME_PROPAG_TEX 100  }
       !TIME_PROPAG_TEX 100
       if (.not. present(virial)) call system_abort("barostat_pre_vel1 needs virial")

       call system_resync_rng()

       !Decay the velocities for dt/2 again barostat part
       vel_decay = matrix_exp(-0.5_dp*dt*((1.0_dp + 3.0_dp/this%Ndof)*this%epsilon_v))
       vel_decay = 0.5_dp*(vel_decay + transpose(vel_decay))
       at%velo(:,:) = vel_decay .mult. at%velo(:,:)

       this%epsilon_r = this%epsilon_r + dt*this%epsilon_v

       ! calc epsilon force
       volume_p = cell_volume(at)
       rand_f_cell = 0.0_dp
       do i=1, 3
       do j=i, 3
	  if (i == j) then
	     rand_f_scale = 3.0_dp
	  else
	     ! empirical - maybe have something to do with fact that matrix is symmetric so there are
	     ! fewer degrees of freedom than first appears?
	     rand_f_scale = 6.0_dp
	  endif
	  rand_f_cell(i,j) = sqrt(rand_f_scale)*sqrt(2.0_dp*BOLTZMANN_K*this%T*this%gamma_epsilon*this%W_epsilon/dt)*ran_normal()
       end do
       end do

       ! symmetrize rand_f_cell
       rand_f_cell(2,1) = rand_f_cell(1,2)
       rand_f_cell(3,1) = rand_f_cell(1,3)
       rand_f_cell(3,2) = rand_f_cell(2,3)

       kinetic_virial = matmul(at%velo*spread(at%mass,dim=1,ncopies=3),transpose(at%velo))
       kinetic_virial = 0.5_dp*(kinetic_virial + transpose(kinetic_virial))
       if (this%finite_strain_formulation) then
	  F_det = matrix3x3_det(this%epsilon_r)
	  call matrix3x3_inverse(transpose(this%epsilon_r), F_T_inv)

	  this%epsilon_f = (3.0_dp*(virial+kinetic_virial+volume_p*(this%epsilon_r .mult. this%stress_ext .mult. transpose(this%epsilon_r))/F_det + &
				    3.0_dp/this%Ndof*kinetic_virial) + rand_f_cell) .mult. F_T_inv
       else
	  this%epsilon_f = 3.0_dp*(virial+kinetic_virial+volume_p*this%stress_ext + &
				   3.0_dp/this%Ndof*kinetic_virial) + rand_f_cell
       endif

       if (this%diagonal_strain .or. this%hydrostatic_strain) then
	 this%epsilon_f(1,2) = 0.0_dp
	 this%epsilon_f(1,3) = 0.0_dp
	 this%epsilon_f(2,3) = 0.0_dp
	 this%epsilon_f(2,1) = 0.0_dp
	 this%epsilon_f(3,1) = 0.0_dp
	 this%epsilon_f(3,2) = 0.0_dp
	 if (this%hydrostatic_strain) then
	   epsilon_f_hydrostatic = (this%epsilon_f(1,1)+ this%epsilon_f(2,2)+ this%epsilon_f(3,3)) / 3.0_dp
	   this%epsilon_f(1,1) = epsilon_f_hydrostatic
	   this%epsilon_f(2,2) = epsilon_f_hydrostatic
	   this%epsilon_f(3,3) = epsilon_f_hydrostatic
	 endif
       endif

       ! half step with epsilon force
       this%epsilon_v = this%epsilon_v + 0.5_dp*dt*this%epsilon_f/this%W_epsilon
       ! half step with epsilon drag
       if (this%finite_strain_formulation) then
	  call matrix3x3_inverse(this%epsilon_r, F_inv)
	  vel_decay = transpose(matrix_exp(-0.5_dp*dt*this%gamma_epsilon*F_inv))
	  vel_decay = 0.5_dp*(vel_decay + transpose(vel_decay))
	  this%epsilon_v = this%epsilon_v .mult. vel_decay
       else
	  this%epsilon_v = this%epsilon_v * exp(-0.5_dp*dt*this%gamma_epsilon)
       endif

       call print("BAROSTAT_KE "//barostat_KE(this))

    end select

  end subroutine barostat_post_vel2

  function barostat_KE(this)
    type(barostat), intent(in) :: this
    real(dp) :: barostat_KE

    select case(this%type)
      case(BAROSTAT_HOOVER_LANGEVIN)
	 barostat_KE = 0.5_dp*this%W_epsilon*sum(this%epsilon_v*transpose(this%epsilon_v))
    end select
  end function barostat_KE

end module barostat_module


C
C $Id: agaxis.f,v 1.11 2008-07-27 00:14:33 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE AGAXIS (IAXS,QTST,QSPA,WCWP,HCWP,XBGA,YBGA,XNDA,YNDA,
     +                   QLUA,UBGA,UNDA,FUNS,QBTP,BASE,QJDP,WMJL,WMJR,
     +                   QMNT,QNDP,WMNL,WMNR,QLTP,QLEX,QLFL,QLOF,QLOS,
     +                   DNLA,WCLM,WCLE,RFNL,QCIM,QCIE,WNLL,WNLR,WNLB,
     +                                                           WNLE)
C
C The routine AGAXIS is used to draw, tick-mark, and label an axis or,
C if ITST is non-zero, to pre-compute the amount of space which will be
C required for numeric labels when the axis is actually drawn.  AGAXIS
C assumes that the last call to the plot-package routine SET was as
C follows (or the equivalent thereof):
C
C    CALL SET (XLCW,XRCW,YBCW,YTCW,0.,1.,0.,1.,1)
C
C where XLCW, XRCW, YBCW, and YTCW are the coordinates of the left,
C right, bottom, and top edges of the curve window, stated as fractions
C of the appropriate edge of the plotter frame.
C
C The arguments of AGAXIS are as follows:
C
C -- IAXS is the number of the axis being drawn - 1, 2, 3, or 4, meaning
C    the left, right, bottom, and top axes, respectively.
C
C -- ITST is an integer specifying what the caller wishes AGAXIS to do,
C    as follows:
C
C    -- If ITST .LT. 0, AGAXIS is to draw only the axis, nothing else.
C
C    -- If ITST .EQ. 0, AGAXIS is to draw, tick, and label the axis.
C
C    -- If ITST .GT. 0, AGAXIS is to pre-compute the amount of space
C       which will be required for numeric labels.  If the labels will
C       not fit in the space provided, AGAXIS is instructed to take
C       action as follows:
C
C       -- ITST .EQ. 1 - no action.
C
C       -- ITST .EQ. 2 - shrink the labels.
C
C       -- ITST .EQ. 3 - re-orient the labels.
C
C       -- ITST .EQ. 4 - shrink and/or re-orient the labels.
C
C -- ISPA is a 0 or a 1, specifying whether or not the axis itself is
C    to be drawn.  If ISPA .NE. 0, the axis is suppressed.  Tick marks
C    and/or labels may still be drawn.
C
C -- WCWP is the width of the curve window, in plotter units.
C
C -- HCWP is the height of the curve window, in plotter units.
C
C -- XBGA, YBGA, XNDA, and YNDA are the x and y coordinates of the ends
C    of the axis.  X coordinates are stated as fractions of the width,
C    y coordinates as fractions of the height, of the curve window.  The
C    axis to be drawn must be either horizontal or vertical (at an angle
C    of 0, 90, 180, or 270 degrees).  The left side, right side, begin-
C    ning, and end of the axis are defined from the viewpoint of a demon
C    standing at (XBGA,YBGA) and staring balefully toward (XNDA,YNDA).
C
C -- LLUA, UBGA, and UNDA define the mapping of the "user" coordinate
C    system (used for data-point coordinates) onto the axis.  If LLUA
C    is zero, the mapping is linear; if LLUA is non-zero, the mapping
C    is logarithmic.  UBGA is the user-system value at the beginning of
C    the axis, UNDA the value at the end of the axis.  The subroutine
C    AGFTOL, which needs these parameters, is actually passed LLUA,
C    UBEG=F(UBGA), and UDIF=F(UNDA)-F(UBGA), where F is the function
C    F(X)=X or the function F(X)=ALOG10(X), depending on LLUA.
C
C -- FUNS is a function-selector, to be used in calls to AGUTOL, which
C    defines the mappings from the user system to the label system and
C    vice-versa for each of the four axes.  The functions defined must
C    be continuous, monotonic, and bounded within the user-system range
C    (UBGA,UNDA) and a little bit outside that range.  The positions
C    of numeric labels and tick marks are chosen in the label system,
C    mapped to the user system, and then onto the axis.
C
C -- NBTP and BASE specify how major ticks are to be positioned in the
C    label coordinate system.  See the routine AGNUMB (arguments NBTP,
C    SBSE, and EXMU) for a description of these arguments.  Note that
C    NBTP .EQ. 0 or BASE .EQ. 0. suppresses both major tick marks and
C    their labels.  Note:  SBSE .EQ. +BASE or -BASE, as needed.
C
C -- QJDP is the major-tick-mark dash pattern (0. .LE. QJDP .LE. 65535.)
C    QJDP .LE. 0 suppresses major ticks.
C
C -- WMJL and WMJR are the distances to the left and right ends of the
C    major tick marks, stated as fractions of the shortest side of the
C    curve window.  Values .EQ. 0 may be used to suppress one or both
C    portions.  Values .GE. 1 may be used to extend a given portion all
C    the way to the edge of the curve window.  (See routine AGCTKO.)
C
C -- NMNT is the number of minor tick marks to be placed between each
C    pair of consecutive major tick marks.  NMNT .EQ. 0 suppresses them.
C
C -- QNDP, WMNL, and WMNR are analogous to QJDP, WMJL, and WMJR, but
C    specify minor-tick-mark characteristics.
C
C -- NLTP, NLEX, and NLFL specify the graphic form of numeric labels, as
C    described in the routine AGNUMB (which see).  Note that NLTP .LE. 0
C    suppresses numeric labels.
C
C -- NLOF and NLOS are first and second choices for the numeric label
C    orientation.  Both must be multiples of 90, specifying an angle
C    measured in degrees counter-clockwise from a vector running from
C    left to right in the curve window.  If ITST .EQ. 0, AGAXIS uses
C    NLOF if it is .GE. 0, NLOS otherwise, for the label orientation.
C    If ITST .NE. 0, AGAXIS initially makes both NLOF and NLOS positive.
C    Then, if ITST .GE. 3, NLOF may or may not be made negative.  (To
C    set the sign of NLOF or NLOS, AGAXIS adds or subtracts 360*K.)
C
C -- DNLA is the desired distance of numeric labels from the axis,
C    positive to the left, negative to the right, of the axis.  The
C    magnitude of DNLA is the size of the gap between the axis and the
C    nearest edge of a label, expressed as a fraction of the smaller
C    dimension of the curve window.  See also RFNL, below.
C
C -- WCLM and WCLE are the desired widths of characters in the mantissa
C    or the exponent, respectively, of numeric labels, expressed as a
C    fraction of the smaller dimension of the curve window.  See also
C    RFNL, below.
C
C -- RFNL is a reduction factor, used as a multiplier for DNLA, WCLM,
C    and WCLE.  If ITST .NE. 0, RFNL is initially set to 1. - then, if
C    ITST .EQ. 2 or 4, it is reset as necessary to shrink the labels.
C
C -- MCIM and MCIE specify the maximum number of characters in the
C    mantissa and exponent, respectively, of a numeric label.  These
C    are input parameters if ITST .EQ. 0, output parameters otherwise.
C
C -- WNLL, WNLR, WNLB, and WNLE are the widths of numeric-label strips
C    on the left side, on the right side, at the beginning, and at the
C    end, of the axis.  These are both input and output parameters of
C    AGAXIS.  On input, they specify the amount of space available for
C    numeric labels - on output, they specify the amount of space used
C    (if ITST .EQ. 0) or required (if ITST .NE. 0).  Each is stated as
C    a fraction of either the width or the height of the curve window,
C    depending on the orientation of the axis in the curve window.
C
C The following common block contains other AUTOGRAPH variables, both
C real and integer, which are not control parameters.  The only ones
C actually used here are ISLD, MWCM, MWCE, and MDLA.  ISLD is a solid-
C line dash pattern (sixteen one bits).  MWCM, MWCE, and MDLA specify
C the minimum allowed values of the width of a character in a label
C mantissa, the width of a character in a label exponent, and the
C distance of a label from the axis.  All are in plotter coordinate
C units.
C
      COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ ,
     +                INIF
      SAVE /AGORIP/
C
C The AUTOGRAPH function AGFPBN is of type integer.
C
      INTEGER AGFPBN
C
C Local data required are as follows:
C
C BFRM is a buffer in which the routine AGNUMB returns the characters of
C a label mantissa.  CTMP holds a sub-string from an AGPWRT call.
C
      CHARACTER*40 BFRM
      CHARACTER*40 CTMP
C
C BFRE is a buffer in which the routine AGNUMB returns the characters of
C a label exponent.
C
      CHARACTER*5 BFRE
C
C XMJT, YMJT, XMNT, and YMNT are used to hold x and y offsets to the
C endpoints of left-of-label and right-of-label portions of major and
C minor tick marks.
C
      DIMENSION XMJT(4),YMJT(4),XMNT(4),YMNT(4)
C
C SMJP is the minimum distance allowed between major tick marks, in
C plotter coordinate units.
C
      DATA SMJP / 1. /
C
C FBGM, FBGP, FNDM, and FNDP are the coordinates of points a little on
C either side of the beginning and end of the axis, as fractions of the
C distance along the axis.
C
      DATA FBGM / -0.000001 /
      DATA FBGP / +0.000001 /
      DATA FNDM / +0.999999 /
      DATA FNDP / +1.000001 /
C
C HCFW is an arithmetic statement function specifying the height of a
C character as a function of its width (not counting "white space").
C The value of the multiplier was determined heuristically, by trying
C various values and seeing which gave the best results.
C
      HCFW(WDTH)=1.25*WDTH
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C This is the initialization section of AGAXIS.
C
C Unpack integer values from floating-point arguments.
C
      ITST=IFIXMM(QTST)
      ISPA=IFIXMM(QSPA)
      LLUA=IFIXMM(QLUA)
      NBTP=IFIXMM(QBTP)
      NMNT=IFIXMM(QMNT)
      NLTP=IFIXMM(QLTP)
      NLEX=IFIXMM(QLEX)
      NLFL=IFIXMM(QLFL)
      NLOF=IFIXMM(QLOF)
      NLOS=IFIXMM(QLOS)
      MCIM=IFIXMM(QCIM)
      MCIE=IFIXMM(QCIE)
C
C Initialize the local flags which specify what entities to draw, using
C values appropriate for the following quick exit.
C
      LDAX=1-ISPA
      LDNL=0
      LDMN=0
C
C If AGAXIS is to draw only the axis, exit immediately.
C
      IF (ITST.LT.0) GO TO 800
C
C If either NBTP or BASE is zeroed, exit immediately.
C
      IF (NBTP.EQ.0.OR.BASE.EQ.0.) GO TO 800
C
C Re-initialize the flag controlling the drawing of numeric labels.
C
      IF (NLTP.NE.0) LDNL=1
C
C If this is not a test run, skip.
C
      IF (ITST.EQ.0) GO TO 101
C
C This is a test run - exit if there are no numeric labels.
C
      IF (LDNL.EQ.0) GO TO 800
C
C This is a test run and the axis is to have numeric labels - initialize
C the numeric-label orientation and sizing parameters.  Clobber drawing.
C
      NLOF=MOD(NLOF+3600,360)
      NLOS=MOD(NLOS+3600,360)
      RFNL=1.
      MCIM=0
      MCIE=0
      LDMJ=0
      LDMN=0
C
C The main body of the initialization follows.
C
C Compute the length of the smaller side of the curve window, in the
C plotter coordinate system.
C
  101 SCWP=MIN(WCWP,HCWP)
C
C Compute a set of direction numbers for the axis, in the curve-window
C coordinate system (the change in x and y from the beginning to the
C end of the axis).
C
      XDNA=XNDA-XBGA
      YDNA=YNDA-YBGA
C
C Compute the length of the axis in the plotter coordinate system and
C its direction cosines.
C
      XDNP=XDNA*WCWP
      YDNP=YDNA*HCWP
      AXLP=MAX(ABS(XDNP),ABS(YDNP))
      AXLP=AXLP*SQRT((XDNP/AXLP)**2+(YDNP/AXLP)**2)
      XDCA=XDNP/AXLP
      YDCA=YDNP/AXLP
C
C Compute the axis orientation angle, in degrees counter-clockwise.
C
      IAOR=MOD(INT(57.2957795130823*ATAN2(YDCA,XDCA)+3600.5),360)
C
C Compute the multiplicative constants required to convert a fraction of
C the axis length to a fraction of the width or height of the curve
C window (a distance in x or y).
C
      CFAX=AXLP/WCWP
      CFAY=AXLP/HCWP
C
C Compute the multiplicative constants required to convert a fraction of
C the axis length to a fraction of the along-axis and perpendicular-to-
C axis sides of the curve window.
C
      CFAA=ABS(XDCA*CFAX+YDCA*CFAY)
      CFAP=ABS(XDCA*CFAY+YDCA*CFAX)
C
C Compute the quantities (UBEG) and (UDIF) for AGFTOL.
C
      IF (LLUA.NE.0) GO TO 102
C
      UBEG=UBGA
      UDIF=UNDA-UBGA
      GO TO 103
C
  102 UBEG=ALOG10(UBGA)
      UDIF=ALOG10(UNDA)-UBEG
C
C SMJT and SMNT are fractions of the axis length and specify the minimum
C space which must be available between two major ticks before the major
C ticks themselves or the minor ticks between them, respectively, may be
C drawn.
C
  103 SMJT=SMJP/AXLP
      SMNT=SMJT*REAL(NMNT+1)
C
C Initialize the fractional numeric-label character heights.
C
      FHCM=0.
      FHCE=0.
C
C If the axis has no numeric labels, skip the following code.
C
      IF (LDNL.EQ.0) GO TO 104
C
C Zero the numeric-label offset.
C
      FNLO=0.
C
C The numeric-label parameters are computed by an internal procedure
C (which see, below).
C
      JMP3=1
      GO TO 500
C
C If this is a test run, skip the following code.
C
  104 IF (ITST.NE.0) GO TO 200
C
C This is not a test run.  First, set up the tick-mark parameters.
C
C Compute the multiplicative constant required to convert a fraction of
C the smaller dimension of the grid to a fraction of the axis length.
C
      CSFA=SCWP/AXLP
C
C Compute the widths of the left and right portions of the numeric-label
C space as fractions of the axis length, affixing an appropriate sign.
C
      FNLL=-WNLL/CFAP
      FNLR=+WNLR/CFAP
C
C Compute a jump parameter to sort out the axis orientations.
C
      JAOR=1+IAOR/90
C
C The routine AGCTKO is used to compute the rest of the tick parameters.
C
      CALL AGCTKO (XBGA,YBGA,XDCA,YDCA,CFAX,CFAY,CSFA,JAOR,   1,QJDP,
     +             WMJL,WMJR,FNLL,FNLR,MJ12,MJ34,XMJT,YMJT)
C
      CALL AGCTKO (XBGA,YBGA,XDCA,YDCA,CFAX,CFAY,CSFA,JAOR,NMNT,QNDP,
     +             WMNL,WMNR,FNLL,FNLR,MN12,MN34,XMNT,YMNT)
C
C Set the flags controlling the drawing of tick marks.
C
      LDMJ=MJ12+MJ34
      LDMN=MN12+MN34
      LDLR=-(LDMJ+LDMN)
C
C If no numeric labels are to be drawn, skip the following code.
C
      IF (LDNL.EQ.0) GO TO 117
C
C Numeric labels are to be drawn.  Precompute parameters which will be
C used to position labels relative to the axis.
C
C Compute the widths and heights of the longest possible label mantissa
C and exponent, as fractions of the length of the axis.
C
      FWLM=REAL(MCIM)*FWCM
      FWLE=REAL(MCIE)*FWCE
      FHLM=FHCM
      FHLE=FHCE
      IF (MCIE.EQ.0) FHLE=0.
C
C Jump on the label-to-axis orientation.
C
      GO TO (105,106,107,108) , JLAO
C
C Label is at a 0-degree angle to the axis.
C
  105 FBLP=-FHLM
      GO TO 109
C
C Label is at a 90-degree angle to the axis.
C
  106 FBLA=0.
      FBLQ=-FWLM-FWLE
      GO TO 110
C
C Label is at a 180-degree angle to the axis.
C
  107 FBLP=FHLM+FHLE
      GO TO 109
C
C Label is at a 270-degree angle to the axis.
C
  108 FBLA=0.
      FBLQ=FWLM+FWLE
      GO TO 110
C
C Label is parallel to the axis.
C
  109 FNLW=FHLM+.5*FHLE
      FBLQ=0.
      GO TO 111
C
C Label is perpendicular to the axis.
C
  110 FNLW=FWLM+FWLE
      FBLP=0.
C
C If the labels will not fit in the space provided, clobber them.
C
  111 IF (.999999*FNLW.LT.FNLR-FNLL) GO TO 112
C
      LDNL=0
      GO TO 117
C
C Jump on the signed value of the numeric-label distance from the axis.
C
  112 IF (DNLA) 113,114,115
C
C Labels are to the right of the axis.
C
  113 FNLC=FDLA+.5*FNLW
      FBLP=FDLA+.5*ABS(FBLP-FHLE)
      FBLQ=FDLA+.5*ABS(FBLQ+FWLM-FWLE)
      GO TO 116
C
C Labels are centered on the axis.
C
  114 FNLC=0.
      FBLP=0.
      FBLQ=0.
      GO TO 116
C
C Labels are to the left of the axis.
C
  115 FNLC=-(FDLA+.5*FNLW)
      FBLP=-(FDLA+.5*ABS(FBLP))
      FBLQ=-(FDLA+.5*ABS(FBLQ-FWLM+FWLE))
C
  116 FNLO=.5*(FNLL+FNLR)-FNLC
C
C If the axis would pass through the offset labels, clobber it.
C
      IF (FNLL*FNLR.LT.0.) LDAX=0
C
C Jump to draw numeric labels and/or tick marks.
C
      GO TO 200
C
C No numeric labels are to be drawn.  If no tick marks are to be drawn
C either, exit.
C
  117 IF (LDLR.EQ.0) GO TO 800
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C The following code directs the process of tick-marking and labelling
C the axis, using the internal procedures which follow it.  If the
C label-coordinate-system value 0 maps onto the axis, tick-marking and
C labelling are done in two passes, one starting at 0 and proceeding
C in a positive direction and the other starting at 0 and proceeding
C in a negative direction.  If the label-coordinate-system value 0 does
C not map onto the axis, only one pass is required.
C
C First, determine the label-coordinate-system values VBGM and VNDP at
C the points FBGM and FNDP, a little beyond the ends of the axis.
C
  200 CALL AGFTOL (IAXS,1,FBGM,VBGM,DUMI,LLUA,UBEG,UDIF,FUNS,NBTP,BASE)
      CALL AGFTOL (IAXS,1,FNDP,VNDP,DUMI,LLUA,UBEG,UDIF,FUNS,NBTP,BASE)
C
C If zero falls on the axis, jump to the two-pass section of the code.
C
      IF ((VBGM.LE.0..AND.VNDP.GE.0.).OR.(VBGM.GE.0..AND.VNDP.LE.0.))
     +                                                         GO TO 201
C
C We may tick-mark and label the axis in a single pass.  Compute an
C appropriate starting value for the exponent/multiplier EXMU.
C
      SBSE=SIGN(BASE,VBGM)
      CALL AGFTOL (IAXS,2,FBGM,EBGM,DUMI,LLUA,UBEG,UDIF,FUNS,NBTP,SBSE)
      CALL AGFTOL (IAXS,2,FNDP,ENDP,DUMI,LLUA,UBEG,UDIF,FUNS,NBTP,SBSE)
      EXMU=MIN(EBGM,ENDP)
      ETMP=MOD(EXMU,1.)
      IF (ETMP.NE.0.) EXMU=EXMU-ETMP+.5+SIGN(.5,EXMU)
C
C Set the numeric-label-space limits for the beginning and end of the
C axis.
C
      FNLB=FBGM-WNLB/CFAA-.5*(FHCM+FHCE)
      FNLE=FNDP+WNLE/CFAA+.5*(FHCM+FHCE)
C
C Jump to an internal procedure to tick-mark and label the axis.  Return
C from there to the termination section of AGAXIS.
C
      JMP1=2
      GO TO 300
C
C Tick marks and labels must be done in two passes.  First, draw the
C tick mark and/or label at the zero position in the label system, using
C an internal procedure below.  A number of parameters must be preset.
C
  201 CALL AGFTOL (IAXS,-1,0.,FRAX,VLCS,LLUA,UBEG,UDIF,FUNS,NBTP,BASE)
C
C Determine whether label is to be drawn or not.
C
      LDLB=0
      IF (LDNL.EQ.0) GO TO 202
      LDLB=1
C
C The mantissa portion of the label consists of the single character 0.
C
      BFRM(1:1)='0'
      NCIM=1
      IPXM=0
C
C The label has no exponent portion.
C
      NCIE=0
C
C Allow the user to change the numeric label.
C
      CALL AGCHNL (IAXS,VLCS,BFRM,40,NCIM,IPXM,BFRE,5,NCIE)
C
C Compute the length of the mantissa, the exponent, and the whole label.
C
      FLLM=REAL(NCIM)*FWCM
      FLLE=REAL(NCIE)*FWCE
      FLLB=FLLM+FLLE
C
C The numeric-label space begins and ends at impossible values.
C
      FNLB=-10.
      FNLE=+10.
C
C Force the labeler to update FNLB, rather than FNLE.
C
      FDIR=1.
C
C Jump to an internal procedure to draw the label and/or the tick mark.
C
  202 JMP2=1
      GO TO 400
C
C Save the position of the zero-point (FRAX, expressed as a fraction of
C the axis length) and preset the parameter DZRT, which is the minimum
C distance from the zero-point at which a major tick mark could occur,
C and the parameter DZRL, which is the minimum distance from the zero-
C point at which a label could occur.  Set the label-space limit FNLE.
C Preset the internal-procedure exit parameter JMP1.
C
  203 JMP1=1
      FZRO=FRAX
      DZRT=MAX(SMJT,1.6*REAL(LDNL)*FHCM)
      IF (LDNL.EQ.0) GO TO 204
      DZRL=FNLB-FZRO
      FNLE=FNDP+WNLE/CFAA+.5*(FHCM+FHCE)
C
C Do the portion of the axis lying in the direction specified by DZRT.
C If it is too short, skip it entirely.
C
  204 FRAX=FZRO+DZRT
      IF (FRAX.LT.FBGM.OR.FRAX.GT.FNDP) GO TO (205,800) , JMP1
C
C Find out whether BASE must be negated for this portion.
C
      CALL AGFTOL (IAXS,1,FRAX,VLCS,DUMI,LLUA,UBEG,UDIF,FUNS,NBTP,BASE)
      SBSE=SIGN(BASE,VLCS)
C
C Compute a starting value of the exponent/multiplier EXMU.
C
      CALL AGFTOL (IAXS,2,FRAX,EXMU,DUMI,LLUA,UBEG,UDIF,FUNS,NBTP,SBSE)
      EXMU=EXMU-MOD(EXMU,1.)+.5+SIGN(.5,EXMU)
C
C Jump to an internal procedure to draw the tick marks and/or labels.
C
      GO TO 300
C
C Set up to do the second portion of the axis, then go do it.
C
  205 JMP1=2
      DZRT=-DZRT
      IF (LDNL.EQ.0) GO TO 204
      FNLB=FBGM-WNLB/CFAA-.5*(FHCM+FHCE)
      FNLE=FZRO-DZRL
      GO TO 204
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C The following is an internal procedure, exited via the assigned-go-to
C variable JMP1.  Its purpose is to tick-mark and label a portion of the
C axis (perhaps the entire axis) at positions determined by consecutive
C values of the parameter EXMU.  It prevents tick marks from piling up
C or passing through the label space and prevents overlapping of labels.
C Tick marks are drawn alternately from left to right or vice-versa.
C
C The caller has provided an initial value of EXMU, but we must consider
C possible minor tick marks in the interval (EXMU-1.,EXMU).
C
  300 EXMU=EXMU-1.
C
C Compute FRAX, which is the fractional distance along the axis, and
C VLCS, which is the value in the label coordinate system corresponding
C to the current value of EXMU.
C
      CALL AGFTOL (IAXS,-2,EXMU,FRAX,VLCS,LLUA,UBEG,UDIF,FUNS,NBTP,SBSE)
C
C Move the current values of EXMU, FRAX, and VLCS to ELST, FLST, and
C VLST, specifying the last values of these parameters.  Then increment
C EXMU by 1. and recompute FRAX and VLCS.  (The loop through consecutive
C values of EXMU begins here.)
C
  301 ELST=EXMU
      FLST=FRAX
      VLST=VLCS
C
      EXMU=EXMU+1.
      CALL AGFTOL (IAXS,-2,EXMU,FRAX,VLCS,LLUA,UBEG,UDIF,FUNS,NBTP,SBSE)
C
C FDIR indicates the direction, FDST the magnitude, of step along axis.
C
      FDIR=FRAX-FLST
      FDST=ABS(FDIR)
C
C Draw minor tick marks, if any, in the interval (FLST,FRAX).
C
      IF (LDMN.EQ.0.OR.FDST.LT.SMNT) GO TO 304
C
C Use the dashed-line pattern for minor tick marks.
C
      CALL DASHDB (AGFPBN(QNDP))
C
C Minor tick marks are equally spaced in the label-coordinate system.
C
      VINC=(VLCS-VLST)/REAL(NMNT+1)
C
      DO 303 I=1,NMNT
        VMNT=VLST+VINC*REAL(I)
        CALL AGFTOL (IAXS,-1,VMNT,FMNT,DUMI,LLUA,UBEG,UDIF,FUNS,NBTP,
     +                                                             SBSE)
        IF (FMNT.LT.FBGP.OR.FMNT.GT.FNDM) GO TO 303
        XPAX=XBGA+FMNT*XDNA
        YPAX=YBGA+FMNT*YDNA
        LDLR=-LDLR
        IF (LDLR.LT.0) GO TO 302
        CALL AGCHAX (0,IAXS,3,VMNT)
        IF (MN12.NE.0) CALL LINED (XPAX+XMNT(1),YPAX+YMNT(1),
     +                             XPAX+XMNT(2),YPAX+YMNT(2))
        IF (MN34.NE.0) CALL LINED (XPAX+XMNT(3),YPAX+YMNT(3),
     +                             XPAX+XMNT(4),YPAX+YMNT(4))
        CALL AGCHAX (1,IAXS,3,VMNT)
        GO TO 303
  302   CALL AGCHAX (0,IAXS,3,VMNT)
        IF (MN34.NE.0) CALL LINED (XPAX+XMNT(4),YPAX+YMNT(4),
     +                             XPAX+XMNT(3),YPAX+YMNT(3))
        IF (MN12.NE.0) CALL LINED (XPAX+XMNT(2),YPAX+YMNT(2),
     +                             XPAX+XMNT(1),YPAX+YMNT(1))
        CALL AGCHAX (1,IAXS,3,VMNT)
  303 CONTINUE
C
C If the end of the axis has been reached, return to caller.
C
  304 IF (FRAX.LT.FBGM.OR.FRAX.GT.FNDP) GO TO (205,800) , JMP1
C
C Draw the major tick mark and/or the numeric label at FRAX.
C
      IF (FDST.LT.SMJT) GO TO 301
      LDLB=0
      IF (LDNL.EQ.0) GO TO 305
      CALL AGNUMB (NBTP,SBSE,EXMU,NLTP,NLEX,NLFL,BFRM,40,NCIM,IPXM,BFRE,
     +                                                           5,NCIE)
      CALL AGCHNL (IAXS,VLCS,BFRM,40,NCIM,IPXM,BFRE,5,NCIE)
C
C If this is not a test run, mantissa and exponent length are checked.
C
      IF (ITST.EQ.0.AND.(NCIM.GT.MCIM.OR.NCIE.GT.MCIE)) GO TO 305
      LDLB=1
      FLLM=REAL(NCIM)*FWCM
      FLLE=REAL(NCIE)*FWCE
      FLLB=FLLM+FLLE
C
C Use the next internal procedure to draw the major tick and/or label.
C
  305 JMP2=2
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C The following is an internal procedure, exited via the assigned-go-to
C variable JMP2.  Its purpose is to draw the major tick mark and/or the
C numeric label at a specified point on the axis or, if ITST is .NE. 0,
C to predict the amount of space which will be required for such items.
C
C Jump if no label is to be drawn.
C
  400 IF (LDLB.EQ.0.OR.NCIM.LE.0) GO TO 410
C
C See if the label will fit without overlapping another label.  To do
C this, first compute its fractional length along the axis (FLAA).
C
      GO TO (401,402,401,402) , JLAO
C
C Label is parallel to the axis.  Allow for inter-label spacing.
C
  401 FLAA=FLLB+FWCM
      GO TO 403
C
C Label is perpendicular to the axis.  Ignore exponent portion.
C
  402 FLAA=1.6*FHCM
C
C Compute the fractional coordinates of the endpoints of the label
C (along the axis) and see if it will fit in the available label space.
C
  403 FLBB=FRAX-.5*FLAA
      FLBE=FRAX+.5*FLAA
C
      IF (FLBB.GE.FNLB.AND.FLBE.LE.FNLE) GO TO 407
C
C Label will not fit.  Omit it or, if this is a test run, see if any
C remedial action is to be taken.
C
      LDLB=0
      IF (ITST.EQ.0) GO TO 411
C
C This is a test run and we have two consecutive labels which overlap.
C See what can be done about it.
C
      GO TO (424,404,406,404) , ITST
C
C We are allowed to shrink the labels.  See if they are minimum-size
C already.  If so, the only other possibility is to re-orient them.
C
  404 IF (IWCM.LE.MWCM.AND.IWCE.LE.MWCE.AND.IDLA.LE.MDLA) GO TO 405
C
C If not, shrink them by an amount based on the extent of the overlap,
C reset the parameters affected, and start from square one.
C
      RFNL=MIN(.9,FDST/(FDST+MAX(FNLB-FLBB,FLBE-FNLE)))*RFNL
      MCIM=0
      MCIE=0
      JMP3=2
      GO TO 500
C
C If labels have already been shrunk to minimum size, see if we can
C re-orient them.  If not, at least continue with finding the maximum
C mantissa and exponent lengths.
C
  405 IF (ITST.NE.4) GO TO 424
C
C Try re-orienting the labels.  If this has already been tried, or it it
C would be pointless, skip it, but continue with finding the maximum
C mantissa and exponent lengths.
C
  406 IF (NLOF.LT.0.OR.NLOS.EQ.NLOF.OR.JLAO.EQ.2.OR.JLAO.EQ.4) GO TO 424
C
C If re-orienting makes sense, reset the appropriate parameters and
C start from square one.
C
      NLOF=NLOF-360
      RFNL=1.
      MCIM=0
      MCIE=0
      JMP3=2
      GO TO 500
C
C Label will fit.  Update the label space limits for next time.
C
  407 IF (FDIR.GE.0.) GO TO 408
      FNLE=FLBB
      GO TO 409
  408 FNLB=FLBE
C
C If this is not just a test shot, go off and draw the tick mark/label.
C
  409 IF (ITST.EQ.0) GO TO 411
C
C If this is a test shot, update the maximum mantissa and exponent
C lengths being generated and exit from this internal procedure.
C
      MCIM=MAX(MCIM,NCIM)
      MCIE=MAX(MCIE,NCIE)
      GO TO 424
C
C No label is to be drawn.  If this is a test shot, exit from this
C internal procedure without drawing the tick mark.
C
  410 IF (ITST.NE.0) GO TO 424
C
C Compute x and y coordinates of current axis point.
C
  411 XPAX=XBGA+FRAX*XDNA
      YPAX=YBGA+FRAX*YDNA
C
C Jump if no major tick-mark is to be drawn.  Otherwise, set up the
C dash pattern for major tick-marks.
C
      IF (LDMJ.EQ.0) GO TO 414
      CALL DASHDB (AGFPBN(QJDP))
C
C Flip the left-to-right/right-to-left direction flag.
C
      LDLR=-LDLR
C
C Draw the first portion of the tick mark.
C
      IF (LDLR) 413,414,412
C
  412 IF (MJ12.NE.0) THEN
        CALL AGCHAX (0,IAXS,2,VLCS)
        CALL LINED (XPAX+XMJT(1),YPAX+YMJT(1),XPAX+XMJT(2),YPAX+YMJT(2))
        CALL AGCHAX (1,IAXS,2,VLCS)
      END IF
      GO TO 414
C
  413 IF (MJ34.NE.0) THEN
        CALL AGCHAX (0,IAXS,2,VLCS)
        CALL LINED (XPAX+XMJT(4),YPAX+YMJT(4),XPAX+XMJT(3),YPAX+YMJT(3))
        CALL AGCHAX (1,IAXS,2,VLCS)
      END IF
C
C Draw the label, if any.
C
  414 IF (LDLB.EQ.0.OR.NCIM.LE.0) GO TO 421
C
C Compute the distances from (XPAX,YPAX) to the beginning of the label -
C along the axis (FBLA) and perpendicular to the axis (FBLP).  Each is a
C directed distance whose magnitude represents a fraction of the length
C of the axis.  The values depend on the label/axis orientation and the
C distance of the label from the axis.  In some cases, these quantities,
C or portions of them, have already been computed.
C
      GO TO (415,416,417,418) , JLAO
C
C Label is at a 0-degree angle to the axis.
C
  415 FBLA=-.5*FLLB
      GO TO 419
C
C Label is at a 90-degree angle to the axis.
C
  416 FBLP=FBLQ+FLLM
      IF (DNLA.EQ.0.) FBLP=.5*FLLB
      GO TO 419
C
C Label is at a 180-degree angle to the axis.
C
  417 FBLA=.5*FLLB
      GO TO 419
C
C Label is at a 270-degree angle to the axis.
C
  418 FBLP=FBLQ-FLLM
      IF (DNLA.EQ.0.) FBLP=-.5*FLLB
C
C Draw the mantissa portion of the label (excluding the "X", if any).
C
  419 DEEX=FBLA*XDCA+(FBLP+FNLO)*YDCA
      DEEY=FBLA*YDCA-(FBLP+FNLO)*XDCA
      CALL AGCHAX (0,IAXS,4,VLCS)
      IF (IPXM.EQ.0) THEN
        CALL AGPWRT (XPAX+CFAX*DEEX,
     +               YPAX+CFAY*DEEY,BFRM,NCIM,IWCM,NLOR,-1)
      ELSE
        CALL AGPWRT (XPAX+CFAX*(DEEX+(FLLM-3.*FWCM)*XDCL),
     +               YPAX+CFAY*(DEEY+(FLLM-3.*FWCM)*YDCL),
     +               BFRM,IPXM-1,IWCM,NLOR,+1)
        CTMP=BFRM(IPXM+1:NCIM)
        CALL AGPWRT (XPAX+CFAX*(DEEX+(FLLM-2.*FWCM)*XDCL),
     +               YPAX+CFAY*(DEEY+(FLLM-2.*FWCM)*YDCL),
     +               CTMP,NCIM-IPXM,IWCM,NLOR,-1)
      END IF
      DEEX=DEEX+FLLM*XDCL
      DEEY=DEEY+FLLM*YDCL
C
C Draw the "X" portion of the mantissa, if it was left out above.
C
      IF (IPXM.EQ.0) GO TO 420
      DEEX=DEEX-2.5*FWCM*XDCL
      DEEY=DEEY-2.5*FWCM*YDCL
      CALL LINE (XPAX+CFAX*(DEEX-.3*FWCM*(XDCL-YDCL)),
     +           YPAX+CFAY*(DEEY-.3*FWCM*(YDCL+XDCL)),
     +           XPAX+CFAX*(DEEX+.3*FWCM*(XDCL-YDCL)),
     +           YPAX+CFAY*(DEEY+.3*FWCM*(YDCL+XDCL)))
      CALL LINE (XPAX+CFAX*(DEEX-.3*FWCM*(XDCL+YDCL)),
     +           YPAX+CFAY*(DEEY-.3*FWCM*(YDCL-XDCL)),
     +           XPAX+CFAX*(DEEX+.3*FWCM*(XDCL+YDCL)),
     +           YPAX+CFAY*(DEEY+.3*FWCM*(YDCL-XDCL)))
      DEEX=DEEX+2.5*FWCM*XDCL
      DEEY=DEEY+2.5*FWCM*YDCL
  420 CALL AGCHAX (1,IAXS,4,VLCS)
C
C Draw the exponent portion of the label (if it has one).
C
      IF (NCIE.EQ.0) GO TO 421
      DEEX=DEEX-.5*FHCM*YDCL
      DEEY=DEEY+.5*FHCM*XDCL
      CALL AGCHAX (0,IAXS,5,VLCS)
      CALL AGPWRT (XPAX+CFAX*DEEX,YPAX+CFAY*DEEY,BFRE,NCIE,IWCE,NLOR,-1)
      CALL AGCHAX (1,IAXS,5,VLCS)
C
C Draw the second portion of the tick mark, if any.
C
  421 IF (LDLR) 423,424,422
C
  422 IF (MJ34.NE.0) THEN
        CALL AGCHAX (0,IAXS,2,VLCS)
        CALL LINED (XPAX+XMJT(3),YPAX+YMJT(3),XPAX+XMJT(4),YPAX+YMJT(4))
        CALL AGCHAX (1,IAXS,2,VLCS)
      END IF
      GO TO 424
C
  423 IF (MJ12.NE.0) THEN
        CALL AGCHAX (0,IAXS,2,VLCS)
        CALL LINED (XPAX+XMJT(2),YPAX+YMJT(2),XPAX+XMJT(1),YPAX+YMJT(1))
        CALL AGCHAX (1,IAXS,2,VLCS)
      END IF
C
C Exit from internal procedure.
C
  424 GO TO (203,301) , JMP2
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C The following is an internal procedure, exited via the assigned-go-to
C variable JMP3.  Its purpose is to compute all numeric-label parameters
C required by AGAXIS.
C
C Compute the desired label orientation and its direction cosines.
C
  500 NLOR=NLOF
      IF (NLOR.LT.0) NLOR=NLOS
C
      XDCL=COS(.017453292519943*REAL(NLOR))
      YDCL=SIN(.017453292519943*REAL(NLOR))
C
C Compute JLAO, which is a computed-go-to jump parameter specifying the
C label-to-axis orientation.
C
      JLAO=1+MOD(NLOR-IAOR+3600,360)/90
C
C Compute the width of a character in the label mantissa, the width of a
C character in the label exponent, and the distance of a label from the
C axis, in the plotter coordinate system.
C
      IWCM=MAX(MWCM,INT(RFNL*ABS(WCLM)*SCWP+.5))
      IWCE=MAX(MWCE,INT(RFNL*ABS(WCLE)*SCWP+.5))
      IDLA=MAX(MDLA,INT(RFNL*ABS(DNLA)*SCWP+.5))
C
C Compute the same quantities as fractions of the axis length.
C
      FWCM=REAL(IWCM)/AXLP
      FWCE=REAL(IWCE)/AXLP
      FDLA=REAL(IDLA)/AXLP
C
C Compute character heights as fractions of the axis length.
C
      FHCM=HCFW(FWCM)
      FHCE=HCFW(FWCE)
C
C Return to internal-procedure caller.
C
      GO TO (104,200,801) , JMP3
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C This is the termination section of AGAXIS.
C
C Update the parameters WNLL and WNLR to reflect the amount of space
C used/needed for numeric labels to the left and right of the axis.
C
  800 IF (LDNL.NE.0) GO TO 801
C
C No numeric labels occur on the axis.  Zero WNLL and WNLR and jump.
C
      WNLL=0.
      WNLR=0.
      GO TO 815
C
C Numeric labels do occur on the axis.  Compute the space required.
C
  801 GO TO (802,803,802,803) , JLAO
C
C Labels are parallel to the axis.
C
  802 FNLW=FHCM
      IF (MCIE.NE.0) FNLW=FNLW+.5*FHCE
      GO TO 804
C
C Labels are perpendicular to the axis.
C
  803 FNLW=REAL(MCIM)*FWCM+REAL(MCIE)*FWCE
C
C Jump on the numeric-label-distance-from-axis parameter DNLA.
C
  804 IF (DNLA) 805,806,807
C
C Labels are to the right of the axis.
C
  805 FNLL=-FDLA
      FNLR=+FDLA+FNLW
      GO TO 808
C
C Labels are centered on the axis.
C
  806 FNLL=+.5*FNLW
      FNLR=+.5*FNLW
      GO TO 808
C
C Labels are to the left of the axis.
C
  807 FNLL=+FDLA+FNLW
      FNLR=-FDLA
C
C Adjust FNLL and FNLR as implied by the numeric-label offset.
C
  808 FNLL=FNLL-FNLO
      FNLR=FNLR+FNLO
C
C If this is not a test run, jump to reset WNLL and WNLR.
C
      IF (ITST.EQ.0) GO TO 814
C
C If this is a test run, see if the labels will fit.  Jump if so.
C
      IF (CFAP*FNLL.LE.WNLL.AND.CFAP*FNLR.LE.WNLR) GO TO 814
C
C If the labels will not fit, we have a problem.  We may or may not be
C able to do anything about it, depending on ITST.
C
      GO TO (814,809,813,809) , ITST
C
C We are allowed to shrink the labels.  See if they are minimum-size
C already.  If so, the only other possibility is to re-orient them.
C
  809 IF (IWCM.LE.MWCM.AND.IWCE.LE.MWCE.AND.IDLA.LE.MDLA) GO TO 812
C
C If not, shrink them by an amount based on the extent of the problem,
C reset the parameters affected and see if the problem is solved.
C
      IF (WNLR+WNLL.GT.0.) GO TO 810
C
      RFNL=.000001*RFNL
      GO TO 811
C
  810 RFNL=MIN(.9,(WNLL+WNLR)/(CFAP*(FNLL+FNLR)))*RFNL
C
  811 JMP3=3
      GO TO 500
C
C If labels have already been shrunk to minimum size, see if we can
C re-orient them.  If not, give up.
C
  812 IF (ITST.NE.3) GO TO 814
C
C Try re-orienting the labels.  If this has already been tried, or if it
C would be pointless, give up.
C
  813 IF (NLOF.LT.0.OR.NLOS.EQ.NLOF.OR.JLAO.EQ.1.OR.JLAO.EQ.3) GO TO 814
C
C If re-orienting makes sense, reset the parameters affected and see if
C the problem is solved.
C
      NLOF=NLOF-360
      RFNL=1.
      JMP3=3
      GO TO 500
C
C Reset WNLL and WNLR for caller.
C
  814 WNLL=FNLL*CFAP
      WNLR=FNLR*CFAP
C
C If this is a test run, we are now done.
C
  815 IF (ITST.GT.0) GO TO 816
C
C Draw the axis, if it is to be drawn.
C
      IF (LDAX.EQ.0) GO TO 816
C
      CALL DASHDB (ISLD)
      CALL AGCHAX (0,IAXS,1,0.)
      CALL LINED (XBGA,YBGA,XNDA,YNDA)
      CALL AGCHAX (1,IAXS,1,0.)
C
C Pack up integer values which might have been changed into the
C corresponding floating-point arguments.
C
  816 QLOF=REAL(NLOF)
      QLOS=REAL(NLOS)
      QCIM=REAL(MCIM)
      QCIE=REAL(MCIE)
C
C Done.
C
      RETURN
C
      END