C$Procedure      INVSTM ( Inverse of state transformation matrix)

      SUBROUTINE INVSTM ( MAT, INVMAT )

C$ Abstract
C
C     Return the inverse of a state transformation matrix.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     ROTATION
C
C$ Keywords
C
C     MATH
C     MATRIX
C     TRANSFORMATION
C
C$ Declarations

      DOUBLE PRECISION      MAT    ( 6, 6 )
      DOUBLE PRECISION      INVMAT ( 6, 6 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     MAT        I   A state transformation matrix.
C     INVMAT     O   The inverse of MAT.
C
C$ Detailed_Input
C
C     MAT        is a state transformation matrix for converting states
C                relative to one frame to states relative to another.
C                The state transformation of a state vector, S, is
C                performed by the matrix-vector product.
C
C                    MAT * S.
C
C                For MAT to be a "true" state transformation matrix
C                it must have the form
C
C                      -            -
C                     |       :      |
C                     |   R   :   0  |
C                     |.......:......|
C                     |       :      |
C                     |  W*R  :   R  |
C                     |       :      |
C                      -            -
C
C                where R is a 3x3 rotation matrix and, 0 is the 3x3 zero
C                matrix and W is a 3x3 skew-symmetric matrix.
C
C                NOTE: no checks are performed on MAT to ensure that it
C                      does indeed have the form described above.
C
C$ Detailed_Output
C
C     INVMAT     is the inverse of MAT under the operation of matrix
C                multiplication.
C
C                If MAT has the form described above, then INVMAT has
C                the form shown below.
C
C                      -             -
C                     |     t  :      |
C                     |    R   :   0  |
C                     |........:......|
C                     |      t :    t |
C                     | (W*R)  :   R  |
C                     |        :      |
C                      -            -
C
C                (The superscript "t" denotes the matrix transpose
C                operation.)
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1) No checks are performed, to insure that the input matrix is
C        indeed a state transformation matrix.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     Given a matrix for transforming states relative frame 1 to
C     states relative frame 2,  the routine produces the inverse
C     matrix.  That is, it returns the matrix for transforming states
C     relative to frame 2 to states relative to frame 1.
C
C     This special routine exists because unlike the inverse of a
C     rotation matrix, the inverse of a state transformation matrix,
C     is NOT simply the transpose of the of the matrix.
C
C$ Examples
C
C     Suppose you had a geometric state, STATE,  of a spacecraft in
C     earth bodyfixed coordinates and wished to express this state
C     relative to earth centered J2000 coordinates.  The following
C     code fragment illustrates how to carry out this computation.
C
C     C
C     C     First get the state transformation from J2000 to earth
C     C     bodyfixed coordinates at the time of interest ET.
C     C
C           EARTH = 399
C           J2000 = 'J2000'
C
C           CALL TISBOD ( J2000, EARTH, ET, MAT )
C
C     C
C     C     Get the inverse of MAT
C     C
C           CALL INVSTM ( MAT,  INVMAT          )
C
C     C
C     C     Transform from bodyfixed state to inertial state.
C     C
C           CALL MXVG ( INVMAT, STATE, 6, 6, ISTATE )
C
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.L. Taber     (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.2, 22-APR-2010 (NJB)
C
C        Header correction: assertions that the output
C        can overwrite the input have been removed.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 29-OCT-1990 (WLT)
C
C-&

C$ Index_Entries
C
C     inverse of state transformation matrix
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               RETURN

      INTEGER               NROWS
      PARAMETER           ( NROWS = 6 )

      INTEGER               NCOLS
      PARAMETER           ( NCOLS = 6 )

      INTEGER               BLOCK
      PARAMETER           ( BLOCK = 3 )

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'INVSTM' )
      END IF

C
C     Not much to this.  Just call the more general routine XPOSBL.
C
      CALL XPOSBL ( MAT, NROWS, NCOLS, BLOCK, INVMAT )

C
C     That's all folks.
C
      CALL CHKOUT ( 'INVSTM' )
      RETURN
      END


*DECK COSQF
      SUBROUTINE COSQF (N, X, WSAVE)
C***BEGIN PROLOGUE  COSQF
C***PURPOSE  Compute the forward cosine transform with odd wave numbers.
C***LIBRARY   SLATEC (FFTPACK)
C***CATEGORY  J1A3
C***TYPE      SINGLE PRECISION (COSQF-S)
C***KEYWORDS  COSINE FOURIER TRANSFORM, FFTPACK
C***AUTHOR  Swarztrauber, P. N., (NCAR)
C***DESCRIPTION
C
C  Subroutine COSQF computes the fast Fourier transform of quarter
C  wave data. That is, COSQF computes the coefficients in a cosine
C  series representation with only odd wave numbers.  The transform
C  is defined below at Output Parameter X
C
C  COSQF is the unnormalized inverse of COSQB since a call of COSQF
C  followed by a call of COSQB will multiply the input sequence X
C  by 4*N.
C
C  The array WSAVE which is used by subroutine COSQF must be
C  initialized by calling subroutine COSQI(N,WSAVE).
C
C
C  Input Parameters
C
C  N       the length of the array X to be transformed.  The method
C          is most efficient when N is a product of small primes.
C
C  X       an array which contains the sequence to be transformed
C
C  WSAVE   a work array which must be dimensioned at least 3*N+15
C          in the program that calls COSQF.  The WSAVE array must be
C          initialized by calling subroutine COSQI(N,WSAVE), and a
C          different WSAVE array must be used for each different
C          value of N.  This initialization does not have to be
C          repeated so long as N remains unchanged.  Thus subsequent
C          transforms can be obtained faster than the first.
C
C  Output Parameters
C
C  X       For I=1,...,N
C
C               X(I) = X(1) plus the sum from K=2 to K=N of
C
C                  2*X(K)*COS((2*I-1)*(K-1)*PI/(2*N))
C
C               A call of COSQF followed by a call of
C               COSQB will multiply the sequence X by 4*N.
C               Therefore COSQB is the unnormalized inverse
C               of COSQF.
C
C  WSAVE   contains initialization calculations which must not
C          be destroyed between calls of COSQF or COSQB.
C
C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
C                 Computations (G. Rodrigue, ed.), Academic Press,
C                 1982, pp. 51-83.
C***ROUTINES CALLED  COSQF1
C***REVISION HISTORY  (YYMMDD)
C   790601  DATE WRITTEN
C   830401  Modified to use SLATEC library source file format.
C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
C           (a) changing dummy array size declarations (1) to (*),
C           (b) changing definition of variable SQRT2 by using
C               FORTRAN intrinsic function SQRT instead of a DATA
C               statement.
C   861211  REVISION DATE from Version 3.2
C   881128  Modified by Dick Valent to meet prologue standards.
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  COSQF
      DIMENSION X(*), WSAVE(*)
C***FIRST EXECUTABLE STATEMENT  COSQF
      SQRT2 = SQRT(2.)
      IF (N-2) 102,101,103
  101 TSQX = SQRT2*X(2)
      X(2) = X(1)-TSQX
      X(1) = X(1)+TSQX
  102 RETURN
  103 CALL COSQF1 (N,X,WSAVE,WSAVE(N+1))
      RETURN
      END


SUBROUTINE p63(input_file,output_file)
!-------------------------------------------------------------------------
! Program 6.3 Plane strain bearing capacity analysis of an elastic-plastic
!             (Mohr-Coulomb) material using 8-node rectangular
!             quadrilaterals. Rigid smooth footing. Displacement control.
!             Viscoplastic strain method.
!-------------------------------------------------------------------------
 USE main
 USE geom
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file

 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::fixed_freedoms,i,iel,incs,iters,iy,i3,i4,i5,j,k,limit,nbo2,     &
   ndim=2,ndof=16,nels,neq,nip=4,nlen,nn,nod=8,nodof=2,nprops=6,np_types, &
   nst=4,nxe,nye
 REAL(iwp)::c,ddt,det,dq1,dq2,dq3,dsbar,dt=1.0e15_iwp,d3=3.0_iwp,         &
   d4=4.0_iwp,d6=6.0_iwp,d180=180.0_iwp,e,f,lode_theta,one=1.0_iwp,pav,   &
   penalty=1.0e20_iwp,phi,pi,pr,presc,psi,qq,qs,sigm,snph,                &
   start_dt=1.e15_iwp,tol,two=2.0_iwp,v,zero=0.0_iwp
 CHARACTER(LEN=15)::argv,element='quadrilateral'
 LOGICAL::converged
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g(:),g_g(:,:),g_num(:,:),kdiag(:),nf(:,:), &
   no(:),node(:),num(:)
 REAL(iwp),ALLOCATABLE::bdylds(:),bee(:,:),bload(:),coord(:,:),dee(:,:),  &
   der(:,:),deriv(:,:),devp(:),eld(:),eload(:),eps(:),erate(:),evp(:),    &
   evpt(:,:,:),flow(:,:),fun(:),gravlo(:),g_coord(:,:),jac(:,:),km(:,:),  &
   kv(:),kvc(:),loads(:),m1(:,:),m2(:,:),m3(:,:),oldis(:),points(:,:),    &
   prop(:,:),react(:),rload(:),sigma(:),storkv(:),stress(:),tensor(:,:,:),&
   totd(:),weights(:),x_coords(:),y_coords(:)
!-----------------------input and initialisation--------------------------

 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)nxe,nye,nbo2,np_types
 CALL mesh_size(element,nod,nels,nn,nxe,nye)
 ALLOCATE(nf(nodof,nn),points(nip,ndim),weights(nip),g_coord(ndim,nn),    &
   x_coords(nxe+1),y_coords(nye+1),num(nod),dee(nst,nst),g_g(ndof,nels),  &
   prop(nprops,np_types),etype(nels),evpt(nst,nip,nels),stress(nst),      &
   tensor(nst,nip,nels),coord(nod,ndim),jac(ndim,ndim),der(ndim,nod),     &
   deriv(ndim,nod),g_num(nod,nels),bee(nst,ndof),km(ndof,ndof),eld(ndof), &
   eps(nst),sigma(nst),bload(ndof),eload(ndof),erate(nst),evp(nst),       &
   devp(nst),g(ndof),m1(nst,nst),m2(nst,nst),m3(nst,nst),flow(nst,nst),   &
   fun(nod),rload(ndof))
 READ(10,*)prop
 etype=1
 IF(np_types>1)READ(10,*)((etype(j+(i-1)*nye),i=1,nxe),j=1,nye)
 ! compute the node freedom array in y direction
 CALL bc_rect(nxe,nye,nf,'y')
 neq=MAXVAL(nf)
 READ(10,*)qs,x_coords,y_coords
 ALLOCATE(kdiag(neq),loads(0:neq),bdylds(0:neq),oldis(0:neq),totd(0:neq), &
   gravlo(0:neq),react(0:neq))
   kdiag=0
!-----------------------loop the elements to find global arrays sizes-----

 elements_1: DO iel=1,nels
   CALL geom_rect(element,iel,x_coords,y_coords,coord,num,'y')
   CALL num_to_g(num,nf,g)
   CALL fkdiag(kdiag,g)
   g_num(:,iel)=num
   g_coord(:,num)=TRANSPOSE(coord)
   g_g(:,iel)=g
 END DO elements_1
 CALL mesh(g_coord,g_num,argv,nlen,12)
 DO i=2,neq
   kdiag(i)=kdiag(i)+kdiag(i-1)
 END DO
 ALLOCATE(kv(kdiag(neq)),kvc(kdiag(neq)))
 WRITE(11,'(2(A,I7))')                                                    &
   " There are",neq," equations and the skyline storage is",kdiag(neq)
 pi=ACOS(-one)
 dt=start_dt
 DO i=1,np_types
   phi=prop(1,i)
   snph=SIN(phi*pi/d180)
   e=prop(5,i)
   v=prop(6,i)
   ddt=d4*(one+v)*(one-two*v)/(e*(one-two*v+snph**2))
   IF(ddt<dt)dt=ddt
 END DO
 CALL sample(element,points,weights)
 gravlo=zero
 kv=zero
!-----------------------element stiffness integration and gravity loads---
 elements_2: DO iel=1,nels
   CALL deemat(dee,prop(5,etype(iel)),prop(6,etype(iel)))
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   g=g_g(:,iel)
   km=zero
   eld=zero
   gauss_pts_2: DO i=1,nip
     CALL shape_fun(fun,points,i)
     CALL shape_der(der,points,i)
     jac=MATMUL(der,coord)
     det=determinant(jac)
     CALL invert(jac)
     deriv=MATMUL(jac,der)
     CALL beemat(bee,deriv)
     km=km+MATMUL(MATMUL(TRANSPOSE(bee),dee),bee)*det*weights(i)
     eld(2:ndof:2)=eld(2:ndof:2)+fun(:)*det*weights(i)
   END DO gauss_pts_2
   CALL fsparv(kv,km,g,kdiag)
   gravlo(g)=gravlo(g)-eld*prop(4,etype(iel))
 END DO elements_2
 kvc=kv
!-----------------------surcharge loads-----------------------------------
 DO i=1,nxe
   i3=g_num(3,(i-1)*nye+1)
   i4=g_num(4,(i-1)*nye+1)
   i5=g_num(5,(i-1)*nye+1)
   qq=(x_coords(i+1)-x_coords(i))*qs
   gravlo(nf(2,i3))=gravlo(nf(2,i3))-qq/d6
   gravlo(nf(2,i4))=gravlo(nf(2,i4))-qq*two/d3
   gravlo(nf(2,i5))=gravlo(nf(2,i5))-qq/d6
 END DO
!-----------------------factorise equations-------------------------------
 CALL sparin(kv,kdiag)
 CALL spabac(kv,gravlo,kdiag)
 gravlo(0)=zero
!-----------------------set up initial stresses---------------------------
 elements_3: DO iel=1,nels
   CALL deemat(dee,prop(5,etype(iel)),prop(6,etype(iel)))
   g=g_g(:,iel)
   eld=gravlo(g)
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   int_pts_2: DO i=1,nip
     CALL shape_der(der,points,i)
     jac=MATMUL(der,coord)
     CALL invert(jac)
     deriv=MATMUL(jac,der)
     CALL beemat(bee,deriv)
     sigma=MATMUL(dee,MATMUL(bee,eld))
     tensor(1,i,iel)=sigma(1)
     tensor(2,i,iel)=sigma(2)
     tensor(3,i,iel)=sigma(3)
     tensor(4,i,iel)=sigma(4)
   END DO int_pts_2
 END DO elements_3
!-----------------------fixed displacement data and factorise equations----
 fixed_freedoms=2*nbo2+1
 ALLOCATE(node(fixed_freedoms),no(fixed_freedoms),storkv(fixed_freedoms))
 node(1)=1
 k=1
 DO i=1,nbo2
   k=k+(2*nye)+1
   node(2*i)=k
   k=k+nye+1
   node(2*i+1)=k
 END DO
 DO i=1,fixed_freedoms
   no(i)=nf(2,node(i))
 END DO
 kv=kvc
 kv(kdiag(no))=kv(kdiag(no))+penalty
 storkv=kv(kdiag(no))
 CALL sparin(kv,kdiag)
!-----------------------load increment loop-------------------------------
 READ(10,*)tol,limit,incs,presc
 oldis=zero
 totd=zero
 WRITE(11,'(/A)')"  step   disp        load1       load2     iters"
 disp_incs: DO iy=1,incs
   iters=0
   bdylds=zero
   react=zero
   evpt=zero
!-----------------------plastic iteration loop----------------------------
   its: DO
     iters=iters+1
     WRITE(*,'(A,E11.3,A,I4)')"  disp",iy*presc,"  iteration",iters
     loads=zero
     loads=loads+bdylds
     DO i=1,fixed_freedoms
       loads(no(i))=storkv(i)*presc
     END DO
     CALL spabac(kv,loads,kdiag)
!-----------------------check plastic convergence-------------------------
     CALL checon(loads,oldis,tol,converged)
     IF(iters==1)converged=.FALSE.
     IF(converged.OR.iters==limit)bdylds=zero
!-----------------------go round the Gauss Points ------------------------
     elements_4: DO iel=1,nels
       phi=prop(1,etype(iel))
       c=prop(2,etype(iel))
       psi=prop(3,etype(iel))
       CALL deemat(dee,prop(5,etype(iel)),prop(6,etype(iel)))
       bload=zero
       rload=zero
       num=g_num(:,iel)
       coord=TRANSPOSE(g_coord(:,num))
       g=g_g(:,iel)
       eld=loads(g)
       gauss_pts_4: DO i=1,nip
         CALL shape_der(der,points,i)
         jac=MATMUL(der,coord)
         det=determinant(jac)
         CALL invert(jac)
         deriv=MATMUL(jac,der)
         CALL beemat(bee,deriv)
         eps=MATMUL(bee,eld)
         eps=eps-evpt(:,i,iel)
         sigma=MATMUL(dee,eps)
         stress=sigma+tensor(:,i,iel)
         CALL invar(stress,sigm,dsbar,lode_theta)
!-----------------------check whether yield is violated-------------------
         CALL mocouf(phi,c,sigm,dsbar,lode_theta,f)
         IF(converged.OR.iters==limit)THEN
           devp=stress
         ELSE
           IF(f>=zero)THEN
             CALL mocouq(psi,dsbar,lode_theta,dq1,dq2,dq3)
             CALL formm(stress,m1,m2,m3)
             flow=f*(m1*dq1+m2*dq2+m3*dq3)
             erate=MATMUL(flow,stress)
             evp=erate*dt
             evpt(:,i,iel)=evpt(:,i,iel)+evp
             devp=MATMUL(dee,evp)
           END IF
         END IF
         IF(f>=zero.OR.(converged.OR.iters==limit))THEN
           eload=MATMUL(devp,bee)
           bload=bload+eload*det*weights(i)
         END IF
!-----------------------update the Gauss Point stresses-------------------
         IF(converged.OR.iters==limit)THEN
           tensor(:,i,iel)=stress
           rload=rload+MATMUL(stress,bee)*det*weights(i)
         END IF
       END DO gauss_pts_4
!-----------------------compute the total bodyloads vector----------------
       bdylds(g)=bdylds(g)+bload
       react(g)=react(g)+rload
       bdylds(0)=zero
     END DO elements_4
     IF(converged.OR.iters==limit)EXIT
   END DO its
   totd=totd+loads
   pr=zero
   DO i=1,fixed_freedoms
     pr=pr+react(no(i))
   END DO
   pr=pr/x_coords(nbo2+1)
   pav=zero
   DO i=1,nbo2
     pav=pav+tensor(2,1,(i-1)*nye+1)+tensor(2,2,(i-1)*nye+1)
   END DO
   pav=pav/(two*nbo2)
   WRITE(11,'(I5,3E12.4,I5)')iy,-totd(1),-pr,-pav,iters
   IF(iters==limit)EXIT
 END DO disp_incs
 CALL dismsh(totd,nf,0.05_iwp,g_coord,g_num,argv,nlen,13)
 CALL vecmsh(totd,nf,0.05_iwp,0.1_iwp,g_coord,g_num,argv,nlen,14)

END SUBROUTINE p63


	SUBROUTINE BDS_PGB  ( grid, igx, igy, qmin, qmax, nbits,
     +			      lendat, cdata, iscale, iret )
C************************************************************************
C* BDS_PGB								*
C*									*
C* This subroutine packs a grid into the simple GRIB packing using the	*
C* number of bits specified.  The packing and unpacking equations are:	*
C*									*
C*	IDATA  =  NINT ( ( GRID - QMIN ) / SCALE )			*
C*	GRID   =  QMIN  +  IDATA * ISCALE				*
C*									*
C* If LENDAT = 0, then the grid is constant everywhere. 		*
C*									*
C* BDS_PGB  ( GRID, IGX, IGY, QMIN, QMAX, NBITS, LENDAT, CDATA, ISCALE,	*
C*            IRET )							*
C*									*
C* Input parameters:							*
C*	GRID (IGX,IGY)	REAL		Grid data			*
C*	IGX		INTEGER		Number of points in x dir	*
C*	IGY		INTEGER		Number of points in y dir	*
C*	QMIN		REAL		Minimum of gridded data		*
C*	QMAX		REAL		Maximum of gridded data		*
C*	NBITS		INTEGER		Number of bits			*
C*									*
C* Input and output parameters:						*
C*	LENDAT		INTEGER		Input: max # of bytes in CDATA	*
C*					Output: # of CDATA bytes needed	*
C*									*
C* Output parameters:							*
C*	CDATA (LENDAT)	CHAR*1		Packed data			*
C*	ISCALE		INTEGER		Power of 2 for binary scaling	*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					-22 = NBITS invalid		*
C*					-23 = invalid data range	*
C*					-26 = array allocation too small*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 3/89						*
C* K. Brill/GSC		 2/90	Fix to find negative max on grid	*
C* K. Brill/NMC		03/92	Fix for constant grid			*
C* K. Brill/HPC		 8/99	Adapted for GDGRIB for byte output	*
C* J. Wu/GSC            07/00   Moved INCLUDE 'ERMISS.FNC' before the   *
C*                              DATA statement                          *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		grid  (*)
	CHARACTER*1	cdata (*)
C*
	INTEGER		nval (8)
	INCLUDE		'ERMISS.FNC'
	DATA		nval / 128, 64, 32, 16, 8, 4, 2, 1 /
C------------------------------------------------------------------------
	iret = 0
	kxky = igx * igy
C
C*	Check for valid input.
C
	IF  ( ( nbits .le. 1 ) .or. ( nbits .gt. 31 ) )  THEN
	    iret = -22
	    RETURN
	END IF
C
C*	Compute the number of output words and initialize the output
C*	buffer and scaling parameter.
C
	lndat = FLOAT ( nbits * kxky ) / 8.
	IF  ( lndat * 8 .ne. nbits * kxky ) lndat = lndat + 1
	IF ( lndat .gt. lendat ) THEN
	    iret = -26
	    RETURN
	END IF
	DO  i = 1, lndat
	    cdata (i) = CHAR (0)
	END DO
	scale = 1.
C
C*	Find the data range and check that it is valid.
C
	qdif = qmax - qmin
	IF  ( qdif .lt. 0. )  THEN
	    iret = -23
	    RETURN
	ELSE IF ( qdif .eq. 0 ) THEN
	    lendat = 0
	    RETURN
	END IF
C
C*	Find the scaling factor.  The scaling factor is set to a
C*	power of 2.
C
	nnnn = 0
	imax = 2 ** nbits - 1
	idat = NINT ( qdif * 2. ** nnnn )
	IF  ( idat .ge. imax )  THEN
	    DO WHILE  ( idat .ge. imax )
		nnnn = nnnn - 1
		idat = qdif * 2. ** nnnn
	    END DO
	  ELSE
	    DO WHILE  ( NINT ( qdif * 2. ** (nnnn+1) ) .lt. imax )
		nnnn = nnnn + 1
	    END DO
	END IF
	scale = 2. ** nnnn
	iscale = -nnnn
C
C*	Add data points to output buffer.
C
	k2pwr = 2 ** nbits
	iword = 1
	ibit  = 1
	icnt = 0
	DO  i = 1, kxky
	    IF  ( ERMISS ( grid (i) ) )  THEN
C
C*		Do nothing.
C
	    ELSE
C
C*		Turn grid value into an integer.
C
		icnt = icnt + 1
		gggg = grid (i) - qmin
		IF  ( gggg .lt. 0. ) gggg = 0.
		idat = NINT ( gggg * scale )
C
C*		Compute value of each bit and store it.
C
		k2 = k2pwr
		DO j = nbits, 1, -1
		    k2 = k2 / 2
		    IF ( idat - k2 .ge. 0 ) THEN
			kbit = 1
			idat = idat - k2
		    ELSE
			kbit = 0
		    END IF
		    icval = ICHAR ( cdata (iword) )
		    icval = icval + kbit * nval (ibit)
		    cdata (iword) = CHAR ( icval )
		    ibit = ibit + 1
		    IF ( ibit .gt. 8 ) THEN
			iword = iword + 1
			ibit = 1
		    END IF
		END DO
	    END IF
	END DO
	lendat = FLOAT ( nbits * icnt ) / 8.
	IF  ( lendat * 8 .ne. nbits * icnt ) lendat = lendat + 1
C*
	RETURN
	END


      SUBROUTINE ZGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS,
     $                  LDVS, WORK, LWORK, RWORK, BWORK, INFO )
*
*  -- LAPACK driver routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      CHARACTER          JOBVS, SORT
      INTEGER            INFO, LDA, LDVS, LWORK, N, SDIM
*     ..
*     .. Array Arguments ..
      LOGICAL            BWORK( * )
      DOUBLE PRECISION   RWORK( * )
      COMPLEX*16         A( LDA, * ), VS( LDVS, * ), W( * ), WORK( * )
*     ..
*     .. Function Arguments ..
      LOGICAL            SELECT
      EXTERNAL           SELECT
*     ..
*
*  Purpose
*  =======
*
*  ZGEES computes for an N-by-N complex nonsymmetric matrix A, the
*  eigenvalues, the Schur form T, and, optionally, the matrix of Schur
*  vectors Z.  This gives the Schur factorization A = Z*T*(Z**H).
*
*  Optionally, it also orders the eigenvalues on the diagonal of the
*  Schur form so that selected eigenvalues are at the top left.
*  The leading columns of Z then form an orthonormal basis for the
*  invariant subspace corresponding to the selected eigenvalues.
*
*  A complex matrix is in Schur form if it is upper triangular.
*
*  Arguments
*  =========
*
*  JOBVS   (input) CHARACTER*1
*          = 'N': Schur vectors are not computed;
*          = 'V': Schur vectors are computed.
*
*  SORT    (input) CHARACTER*1
*          Specifies whether or not to order the eigenvalues on the
*          diagonal of the Schur form.
*          = 'N': Eigenvalues are not ordered:
*          = 'S': Eigenvalues are ordered (see SELECT).
*
*  SELECT  (external procedure) LOGICAL FUNCTION of one COMPLEX*16 argument
*          SELECT must be declared EXTERNAL in the calling subroutine.
*          If SORT = 'S', SELECT is used to select eigenvalues to order
*          to the top left of the Schur form.
*          IF SORT = 'N', SELECT is not referenced.
*          The eigenvalue W(j) is selected if SELECT(W(j)) is true.
*
*  N       (input) INTEGER
*          The order of the matrix A. N >= 0.
*
*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
*          On entry, the N-by-N matrix A.
*          On exit, A has been overwritten by its Schur form T.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  SDIM    (output) INTEGER
*          If SORT = 'N', SDIM = 0.
*          If SORT = 'S', SDIM = number of eigenvalues for which
*                         SELECT is true.
*
*  W       (output) COMPLEX*16 array, dimension (N)
*          W contains the computed eigenvalues, in the same order that
*          they appear on the diagonal of the output Schur form T.
*
*  VS      (output) COMPLEX*16 array, dimension (LDVS,N)
*          If JOBVS = 'V', VS contains the unitary matrix Z of Schur
*          vectors.
*          If JOBVS = 'N', VS is not referenced.
*
*  LDVS    (input) INTEGER
*          The leading dimension of the array VS.  LDVS >= 1; if
*          JOBVS = 'V', LDVS >= N.
*
*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
*  LWORK   (input) INTEGER
*          The dimension of the array WORK.  LWORK >= max(1,2*N).
*          For good performance, LWORK must generally be larger.
*
*          If LWORK = -1, then a workspace query is assumed; the routine
*          only calculates the optimal size of the WORK array, returns
*          this value as the first entry of the WORK array, and no error
*          message related to LWORK is issued by XERBLA.
*
*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)
*
*  BWORK   (workspace) LOGICAL array, dimension (N)
*          Not referenced if SORT = 'N'.
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -i, the i-th argument had an illegal value.
*          > 0: if INFO = i, and i is
*               <= N:  the QR algorithm failed to compute all the
*                      eigenvalues; elements 1:ILO-1 and i+1:N of W
*                      contain those eigenvalues which have converged;
*                      if JOBVS = 'V', VS contains the matrix which
*                      reduces A to its partially converged Schur form.
*               = N+1: the eigenvalues could not be reordered because
*                      some eigenvalues were too close to separate (the
*                      problem is very ill-conditioned);
*               = N+2: after reordering, roundoff changed values of
*                      some complex eigenvalues so that leading
*                      eigenvalues in the Schur form no longer satisfy
*                      SELECT = .TRUE..  This could also be caused by
*                      underflow due to scaling.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LQUERY, SCALEA, WANTST, WANTVS
      INTEGER            HSWORK, I, IBAL, ICOND, IERR, IEVAL, IHI, ILO,
     $                   ITAU, IWRK, MAXWRK, MINWRK
      DOUBLE PRECISION   ANRM, BIGNUM, CSCALE, EPS, S, SEP, SMLNUM
*     ..
*     .. Local Arrays ..
      DOUBLE PRECISION   DUM( 1 )
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLABAD, XERBLA, ZCOPY, ZGEBAK, ZGEBAL, ZGEHRD,
     $                   ZHSEQR, ZLACPY, ZLASCL, ZTRSEN, ZUNGHR
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH, ZLANGE
      EXTERNAL           LSAME, ILAENV, DLAMCH, ZLANGE
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, SQRT
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
      INFO = 0
      LQUERY = ( LWORK.EQ.-1 )
      WANTVS = LSAME( JOBVS, 'V' )
      WANTST = LSAME( SORT, 'S' )
      IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDVS.LT.1 .OR. ( WANTVS .AND. LDVS.LT.N ) ) THEN
         INFO = -10
      END IF
*
*     Compute workspace
*      (Note: Comments in the code beginning "Workspace:" describe the
*       minimal amount of workspace needed at that point in the code,
*       as well as the preferred amount for good performance.
*       CWorkspace refers to complex workspace, and RWorkspace to real
*       workspace. NB refers to the optimal block size for the
*       immediately following subroutine, as returned by ILAENV.
*       HSWORK refers to the workspace preferred by ZHSEQR, as
*       calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
*       the worst case.)
*
      IF( INFO.EQ.0 ) THEN
         IF( N.EQ.0 ) THEN
            MINWRK = 1
            MAXWRK = 1
         ELSE
            MAXWRK = N + N*ILAENV( 1, 'ZGEHRD', ' ', N, 1, N, 0 )
            MINWRK = 2*N
*
            CALL ZHSEQR( 'S', JOBVS, N, 1, N, A, LDA, W, VS, LDVS,
     $             WORK, -1, IEVAL )
            HSWORK = WORK( 1 )
*
            IF( .NOT.WANTVS ) THEN
               MAXWRK = MAX( MAXWRK, HSWORK )
            ELSE
               MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR',
     $                       ' ', N, 1, N, -1 ) )
               MAXWRK = MAX( MAXWRK, HSWORK )
            END IF
         END IF
         WORK( 1 ) = MAXWRK
*
         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
            INFO = -12
         END IF
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZGEES ', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 ) THEN
         SDIM = 0
         RETURN
      END IF
*
*     Get machine constants
*
      EPS = DLAMCH( 'P' )
      SMLNUM = DLAMCH( 'S' )
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
      SMLNUM = SQRT( SMLNUM ) / EPS
      BIGNUM = ONE / SMLNUM
*
*     Scale A if max element outside range [SMLNUM,BIGNUM]
*
      ANRM = ZLANGE( 'M', N, N, A, LDA, DUM )
      SCALEA = .FALSE.
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
         SCALEA = .TRUE.
         CSCALE = SMLNUM
      ELSE IF( ANRM.GT.BIGNUM ) THEN
         SCALEA = .TRUE.
         CSCALE = BIGNUM
      END IF
      IF( SCALEA )
     $   CALL ZLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
*
*     Permute the matrix to make it more nearly triangular
*     (CWorkspace: none)
*     (RWorkspace: need N)
*
      IBAL = 1
      CALL ZGEBAL( 'P', N, A, LDA, ILO, IHI, RWORK( IBAL ), IERR )
*
*     Reduce to upper Hessenberg form
*     (CWorkspace: need 2*N, prefer N+N*NB)
*     (RWorkspace: none)
*
      ITAU = 1
      IWRK = N + ITAU
      CALL ZGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
     $             LWORK-IWRK+1, IERR )
*
      IF( WANTVS ) THEN
*
*        Copy Householder vectors to VS
*
         CALL ZLACPY( 'L', N, N, A, LDA, VS, LDVS )
*
*        Generate unitary matrix in VS
*        (CWorkspace: need 2*N-1, prefer N+(N-1)*NB)
*        (RWorkspace: none)
*
         CALL ZUNGHR( N, ILO, IHI, VS, LDVS, WORK( ITAU ), WORK( IWRK ),
     $                LWORK-IWRK+1, IERR )
      END IF
*
      SDIM = 0
*
*     Perform QR iteration, accumulating Schur vectors in VS if desired
*     (CWorkspace: need 1, prefer HSWORK (see comments) )
*     (RWorkspace: none)
*
      IWRK = ITAU
      CALL ZHSEQR( 'S', JOBVS, N, ILO, IHI, A, LDA, W, VS, LDVS,
     $             WORK( IWRK ), LWORK-IWRK+1, IEVAL )
      IF( IEVAL.GT.0 )
     $   INFO = IEVAL
*
*     Sort eigenvalues if desired
*
      IF( WANTST .AND. INFO.EQ.0 ) THEN
         IF( SCALEA )
     $      CALL ZLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, W, N, IERR )
         DO 10 I = 1, N
            BWORK( I ) = SELECT( W( I ) )
   10    CONTINUE
*
*        Reorder eigenvalues and transform Schur vectors
*        (CWorkspace: none)
*        (RWorkspace: none)
*
         CALL ZTRSEN( 'N', JOBVS, BWORK, N, A, LDA, VS, LDVS, W, SDIM,
     $                S, SEP, WORK( IWRK ), LWORK-IWRK+1, ICOND )
      END IF
*
      IF( WANTVS ) THEN
*
*        Undo balancing
*        (CWorkspace: none)
*        (RWorkspace: need N)
*
         CALL ZGEBAK( 'P', 'R', N, ILO, IHI, RWORK( IBAL ), N, VS, LDVS,
     $                IERR )
      END IF
*
      IF( SCALEA ) THEN
*
*        Undo scaling for the Schur form of A
*
         CALL ZLASCL( 'U', 0, 0, CSCALE, ANRM, N, N, A, LDA, IERR )
         CALL ZCOPY( N, A, LDA+1, W, 1 )
      END IF
*
      WORK( 1 ) = MAXWRK
      RETURN
*
*     End of ZGEES
*
      END


!==============================================================================!
  subroutine Field_Mod_Calculate_Grad_Matrix(flow)
!------------------------------------------------------------------------------!
!   Calculates gradient matrix.                                                !
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Field_Type) :: flow
!-----------------------------------[Locals]-----------------------------------!
  type(Grid_Type), pointer :: grid
  integer                  :: c, c1, c2, s
  real                     :: dx_c1, dy_c1, dz_c1, dx_c2, dy_c2, dz_c2
  real                     :: jac, g_inv(6)
!==============================================================================!

  ! Take alias
  grid => flow % pnt_grid

  do c = 1, grid % n_cells
    flow % grad(1,c) = 0.0
    flow % grad(2,c) = 0.0
    flow % grad(3,c) = 0.0
    flow % grad(4,c) = 0.0
    flow % grad(5,c) = 0.0
    flow % grad(6,c) = 0.0
  end do

  do s = 1, grid % n_faces
    c1 = grid % faces_c(1,s)
    c2 = grid % faces_c(2,s)

    dx_c1 = grid % dx(s)
    dy_c1 = grid % dy(s)
    dz_c1 = grid % dz(s)
    dx_c2 = grid % dx(s)
    dy_c2 = grid % dy(s)
    dz_c2 = grid % dz(s)

    flow % grad(1,c1)=flow % grad(1,c1) + dx_c1*dx_c1    ! 1,1
    flow % grad(2,c1)=flow % grad(2,c1) + dy_c1*dy_c1    ! 2,2
    flow % grad(3,c1)=flow % grad(3,c1) + dz_c1*dz_c1    ! 3,3
    flow % grad(4,c1)=flow % grad(4,c1) + dx_c1*dy_c1    ! 1,2  &  2,1
    flow % grad(5,c1)=flow % grad(5,c1) + dx_c1*dz_c1    ! 1,3  &  3,1
    flow % grad(6,c1)=flow % grad(6,c1) + dy_c1*dz_c1    ! 2,3  &  3,2
    if(c2 > 0) then  ! this is enough even for parallel
      flow % grad(1,c2)=flow % grad(1,c2) + dx_c2*dx_c2  ! 1,1
      flow % grad(2,c2)=flow % grad(2,c2) + dy_c2*dy_c2  ! 2,2
      flow % grad(3,c2)=flow % grad(3,c2) + dz_c2*dz_c2  ! 3,3
      flow % grad(4,c2)=flow % grad(4,c2) + dx_c2*dy_c2  ! 1,2  &  2,1
      flow % grad(5,c2)=flow % grad(5,c2) + dx_c2*dz_c2  ! 1,3  &  3,1
      flow % grad(6,c2)=flow % grad(6,c2) + dy_c2*dz_c2  ! 2,3  &  3,2
    end if

  end do

  !--------------------------------!
  !   Find the inverse of matrix   !
  !--------------------------------!
  do c = 1, grid % n_cells
    jac  =       flow % grad(1,c) * flow % grad(2,c) * flow % grad(3,c)  &
         -       flow % grad(1,c) * flow % grad(6,c) * flow % grad(6,c)  &
         -       flow % grad(4,c) * flow % grad(4,c) * flow % grad(3,c)  &
         + 2.0 * flow % grad(4,c) * flow % grad(5,c) * flow % grad(6,c)  &
         -       flow % grad(5,c) * flow % grad(5,c) * flow % grad(2,c)

    g_inv(1) = +(  flow % grad(2,c) * flow % grad(3,c)  &
                 - flow % grad(6,c) * flow % grad(6,c) ) / (jac+TINY)
    g_inv(2) = +(  flow % grad(1,c) * flow % grad(3,c)  &
                 - flow % grad(5,c) * flow % grad(5,c) ) / (jac+TINY)
    g_inv(3) = +(  flow % grad(1,c) * flow % grad(2,c)  &
                 - flow % grad(4,c) * flow % grad(4,c) ) / (jac+TINY)
    g_inv(4) = -(  flow % grad(4,c) * flow % grad(3,c)  &
                 - flow % grad(5,c) * flow % grad(6,c) ) / (jac+TINY)
    g_inv(5) = +(  flow % grad(4,c) * flow % grad(6,c)  &
                 - flow % grad(5,c) * flow % grad(2,c) ) / (jac+TINY)
    g_inv(6) = -(  flow % grad(1,c) * flow % grad(6,c)  &
                 - flow % grad(4,c) * flow % grad(5,c) ) / (jac+TINY)

    flow % grad(1,c) = g_inv(1)
    flow % grad(2,c) = g_inv(2)
    flow % grad(3,c) = g_inv(3)
    flow % grad(4,c) = g_inv(4)
    flow % grad(5,c) = g_inv(5)
    flow % grad(6,c) = g_inv(6)
  end do

  end subroutine


      SUBROUTINE FILTERn(Z)
      USE global
      IMPLICIT NONE
!     This function implements 3 point filter for j=3
!
      REAL*8 ::  Z(1,NXP4), Z1(1,NXP4)
      INTEGER ::  IC

      DO 117 IC = 3, NXP2
         Z1(1,IC)=(-1*Z(1,IC-2)+4*Z(1,IC-1)+10*Z(1,IC)+4*Z(1,IC+1) &
     &   -Z(1,IC+2))/16
  117 CONTINUE
      Z = Z1
!---- Boundary condition -------
      CALL boundary_condition(Z(1,:))
!------------------------------
      RETURN
      END


!========================================================================
!
!                   S P E C F E M 2 D  Version 7 . 0
!                   --------------------------------
!
!     Main historical authors: Dimitri Komatitsch and Jeroen Tromp
!                        Princeton University, USA
!                and CNRS / University of Marseille, France
!                 (there are currently many more authors!)
! (c) Princeton University and CNRS / University of Marseille, April 2014
!
! This software is a computer program whose purpose is to solve
! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
! using a spectral-element method (SEM).
!
! This software is governed by the CeCILL license under French law and
! abiding by the rules of distribution of free software. You can use,
! modify and/or redistribute the software under the terms of the CeCILL
! license as circulated by CEA, CNRS and Inria at the following URL
! "http://www.cecill.info".
!
! As a counterpart to the access to the source code and rights to copy,
! modify and redistribute granted by the license, users are provided only
! with a limited warranty and the software's author, the holder of the
! economic rights, and the successive licensors have only limited
! liability.
!
! In this respect, the user's attention is drawn to the risks associated
! with loading, using, modifying and/or developing or reproducing the
! software by the user in light of its specific status of free software,
! that may mean that it is complicated to manipulate, and that also
! therefore means that it is reserved for developers and experienced
! professionals having in-depth computer knowledge. Users are therefore
! encouraged to load and test the software's suitability as regards their
! requirements in conditions enabling the security of their systems and/or
! data to be ensured and, more generally, to use and operate it in the
! same conditions as regards security.
!
! The full text of the license is available in file "LICENSE".
!
!========================================================================

! Recompute 2D jacobian at a given point in a 4-node or 9-node element
! Compute also the global coordinates of the point defined by: (xi,gamma,ispec)

  subroutine recompute_jacobian(xi,gamma,x,z,xix,xiz,gammax,gammaz,jacobian,coorg,knods,ispec,ngnod,nspec,npgeo, &
                      stop_if_negative_jacobian)

  implicit none

  include "constants.h"

  integer ispec,ngnod,nspec,npgeo
  double precision x,z,xix,xiz,gammax,gammaz
  double precision xi,gamma,jacobian

  integer knods(ngnod,nspec)
  double precision coorg(NDIM,npgeo)

! 2D shape functions and their derivatives at receiver
  double precision shape2D(ngnod)
  double precision dershape2D(NDIM,ngnod)

  double precision xxi,zxi,xgamma,zgamma,xelm,zelm

  integer ia,nnum

  logical stop_if_negative_jacobian

! only one problematic element is output to OpenDX for now in case of elements with a negative Jacobian
  integer, parameter :: ntotspecAVS_DX = 1

! recompute jacobian for any (xi,gamma) point, not necessarily a GLL point

! create the 2D shape functions and then the Jacobian
  call define_shape_functions(shape2D,dershape2D,xi,gamma,ngnod)

! compute coordinates and jacobian matrix
  x = ZERO
  z = ZERO

  xxi = ZERO
  zxi = ZERO
  xgamma = ZERO
  zgamma = ZERO

  do ia=1,ngnod

    nnum = knods(ia,ispec)

    xelm = coorg(1,nnum)
    zelm = coorg(2,nnum)

    x = x + shape2D(ia)*xelm
    z = z + shape2D(ia)*zelm

    xxi = xxi + dershape2D(1,ia)*xelm
    zxi = zxi + dershape2D(1,ia)*zelm
    xgamma = xgamma + dershape2D(2,ia)*xelm
    zgamma = zgamma + dershape2D(2,ia)*zelm

  enddo

  jacobian = xxi*zgamma - xgamma*zxi

! the Jacobian is negative, so far this means that there is an error in the mesh
! therefore print the coordinates of the mesh points of this element
! and also create an OpenDX file to visualize it
  if(jacobian <= ZERO .and. stop_if_negative_jacobian) then

! print the coordinates of the mesh points of this element
    print *, 'ispec = ', ispec
    print *, 'ngnod = ', ngnod
    do ia=1,ngnod
      nnum = knods(ia,ispec)
      xelm = coorg(1,nnum)
      zelm = coorg(2,nnum)
      print *,'node ', ia,' x,y = ',xelm,zelm
    enddo

! create an OpenDX file to visualize this element
    open(unit=11,file='DX_first_element_with_negative_jacobian.dx',status='unknown')

! output the points (the mesh is flat therefore the third coordinate is zero)
    write(11,*) 'object 1 class array type float rank 1 shape 3 items ',ngnod,' data follows'
    do ia=1,ngnod
      nnum = knods(ia,ispec)
      xelm = coorg(1,nnum)
      zelm = coorg(2,nnum)
      write(11,*) xelm,zelm,' 0'
    enddo

! output the element (use its four corners only for now)
    write(11,*) 'object 2 class array type int rank 1 shape 4 items ',ntotspecAVS_DX,' data follows'
! point order in OpenDX is 1,4,2,3 *not* 1,2,3,4 as in AVS
    write(11,*) '0 3 1 2'

! output element data
    write(11,*) 'attribute "element type" string "quads"'
    write(11,*) 'attribute "ref" string "positions"'
    write(11,*) 'object 3 class array type float rank 0 items ',ntotspecAVS_DX,' data follows'

! output dummy data value
    write(11,*) '1'

! define OpenDX field
    write(11,*) 'attribute "dep" string "connections"'
    write(11,*) 'object "irregular positions irregular connections" class field'
    write(11,*) 'component "positions" value 1'
    write(11,*) 'component "connections" value 2'
    write(11,*) 'component "data" value 3'
    write(11,*) 'end'

! close OpenDX file
    close(11)

    call exit_MPI('negative 2D Jacobian, element saved in DX_first_element_with_negative_jacobian.dx')
  endif

! invert the relation
  xix = zgamma / jacobian
  gammax = - zxi / jacobian
  xiz = - xgamma / jacobian
  gammaz = xxi / jacobian

  end subroutine recompute_jacobian


subroutine units(scale_l,scale_t,scale_d,scale_v,scale_nH,scale_T2)
  use amr_commons
  use hydro_commons
  use cooling_module
  real(dp)::scale_nH,scale_T2,scale_t,scale_v,scale_d,scale_l
  !-----------------------------------------------------------------------
  ! Conversion factors from user units into cgs units
  ! For gravity runs, make sure that G=1 in user units.
  !-----------------------------------------------------------------------

  ! scale_d converts mass density from user units into g/cc
  scale_d = units_density
  if(cosmo) scale_d = omega_m * rhoc *(h0/100.)**2 / aexp**3

  ! scale_t converts time from user units into seconds
  scale_t = units_time
  if(cosmo) scale_t = aexp**2 / (h0*1d5/3.08d24)

  ! scale_l converts distance from user units into cm
  scale_l = units_length
  if(cosmo) scale_l = aexp * boxlen_ini * 3.08d24 / (h0/100)

  ! scale_v converts velocity in user units into cm/s
  scale_v = scale_l / scale_t

  ! scale_T2 converts (P/rho) in user unit into (T/mu) in Kelvin
  scale_T2 = mH/kB * scale_v**2

  ! scale_nH converts rho in user units into nH in H/cc
  scale_nH = X/mH * scale_d

end subroutine units


      double precision function betain(x, p, q, beta, ifault)
      implicit double precision (a-h, o-z)
c
c     algorithm as 63  appl. statist. (1973), vol.22, no.3
c
c     computes incomplete beta function ratio for arguments
c     x between zero and one, p and q positive.
c     log of complete beta function, beta, is assumed to be known
c
      logical indx
c
c     define accuracy and initialise
c
      data zero/0.0d0/, one/1.0d0/, acu/0.1d-14/
      betain=x
c
c     test for admissibility of arguments
c
      ifault=1
      if(p.le.zero .or. q.le.zero) return
      ifault=2
      if(x.lt.zero .or. x.gt.one) return
      ifault=0
      if(x.eq.zero .or. x.eq. one) return
c
c     change tail if necessary and determine s
c
      psq=p+q
      cx=one-x
      if(p.ge.psq*x) goto 1
      xx=cx
      cx=x
      pp=q
      qq=p
      indx=.true.
      goto 2
    1 xx=x
      pp=p
      qq=q
      indx=.false.
    2 term=one
      ai=one
      betain=one
      ns=qq+cx*psq
c
c     user soper's reduction formulae.
c
      rx=xx/cx
    3 temp=qq-ai
      if(ns.eq.0) rx=xx
    4 term=term*temp*rx/(pp+ai)
      betain=betain+term
      temp=abs(term)
      if(temp.le.acu .and. temp.le.acu*betain) goto 5
      ai=ai+one
      ns=ns-1
      if(ns.ge.0) goto 3
      temp=psq
      psq=psq+one
      goto 4
c
c     calculate result
c
    5 betain=betain*exp(pp*log(xx)+(qq-one)*log(cx)-beta)/pp
      if(indx) betain=one-betain
      return
      end


chapter xiii, example 2m. cubic spline interpolant at knot averages
c			 with good knots. modified around label 4.
c  from  * a practical guide to splines *  by c. de boor
calls splint(banfac/slv,bsplvb),newnot,bsplpp(bsplvb*)
c     parameter nmax=20,nmaxp6=26,nmaxp2=22,nmaxt7=140
      integer i,istep,iter,itermx,n,nhigh,nmk,nlow
c     real algerp,aloger,bcoef(nmaxp2),break(nmax),decay,dx,errmax,
c    *	  c(4,nmax),g,gtau(nmax),h,pnatx,scrtch(nmaxt7),step,t(nmaxp6),
c    *	  tau(nmax),tnew(nmax)
      real algerp,aloger,bcoef(22),break(20),decay,dx,errmax,
     *	  c(4,20),g,gtau(20),h,pnatx,scrtch(140),step,t(26),
     *	  tau(20),tnew(20),x
c     istep and step = float(istep) specify point density for error det-
c     ermination.
      data step, istep /20., 20/
c				the function  g  is to be interpolated .
      g(x) = sqrt(x+1.)
      decay = 0.
c      read in the number of iterations to be carried out and the lower
c      and upper limit for the number  n  of data points to be used.
      read 500,itermx,nlow,nhigh
  500 format(3i3)
      print 600, itermx
  600 format(i4,22h cycles through newnot//
     *	    28h  n   max.error	 decay exp./)
c				  loop over  n = number of data points .
      do 40 n=nlow,nhigh,2
	 if (n .eq. nlow)		go to 4
	 call newnot ( break, c, l, 4, tnew, l+2, scrtch )
	 l = l + 2
	 t(5+l) = 1.
	 t(6+l) = 1.
	 iter = 1
					go to 15
    4	 nmk = n-4
	 h = 2./float(nmk+1)
	 do 5 i=1,4
	    t(i) = -1.
    5	    t(n+i) = 1.
	 if (nmk .lt. 1)		go to 10
	 do 6 i=1,nmk
    6	    t(i+4) = float(i)*h - 1.
   10	 iter = 1
c		construct cubic spline interpolant. then, itermx  times,
c		 determine new knots from it and find a new interpolant.
   11	    do 12 i=1,n
	       tau(i) = (t(i+1)+t(i+2)+t(i+3))/3.
   12	       gtau(i) = g(tau(i))
	    call splint ( tau, gtau, t, n, 4, scrtch, bcoef, iflag )
	    call bsplpp ( t, bcoef, n, 4, scrtch, break, c, l )
	    if (iter .gt. itermx)	go to 19
	    iter = iter + 1
	    call newnot ( break, c, l, 4, tnew, l, scrtch )
   15	    do 18 i=2,l
   18	       t(3+i) = tnew(i)
					go to 11
c		       estimate max.interpolation error on  (-1,1) .
   19	 errmax = 0.
c			    loop over polynomial pieces of interpolant .
	 do 30 i=1,l
	    dx = (break(i+1)-break(i))/step
c		 interpolation error is calculated at  istep  points per
c		     polynomial piece .
	    do 30 j=1,istep
	       h = float(j)*dx
	       pnatx = c(1,i)+h*(c(2,i)+h*(c(3,i)+h*c(4,i)/3.)/2.)
   30	    errmax = amax1(errmax,abs(g(break(i)+h)-pnatx))
c					      calculate decay exponent .
	 aloger = alog(errmax)
	 if (n .gt. nlow)  decay =
     *	     (aloger - algerp)/alog(float(n)/float(n-2))
	 algerp = aloger
c
   40	 print 640,n,errmax,decay
  640 format(i3,e12.4,f11.2)
					stop
      end


*> \brief \b CUNG2L generates all or part of the unitary matrix Q from a QL factorization determined by cgeqlf (unblocked algorithm).
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CUNG2L + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE CUNG2L( M, N, K, A, LDA, TAU, WORK, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            INFO, K, LDA, M, N
*       ..
*       .. Array Arguments ..
*       COMPLEX            A( LDA, * ), TAU( * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CUNG2L generates an m by n complex matrix Q with orthonormal columns,
*> which is defined as the last n columns of a product of k elementary
*> reflectors of order m
*>
*>       Q  =  H(k) . . . H(2) H(1)
*>
*> as returned by CGEQLF.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix Q. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrix Q. M >= N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*>          K is INTEGER
*>          The number of elementary reflectors whose product defines the
*>          matrix Q. N >= K >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is COMPLEX array, dimension (LDA,N)
*>          On entry, the (n-k+i)-th column must contain the vector which
*>          defines the elementary reflector H(i), for i = 1,2,...,k, as
*>          returned by CGEQLF in the last k columns of its array
*>          argument A.
*>          On exit, the m-by-n matrix Q.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The first dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*>          TAU is COMPLEX array, dimension (K)
*>          TAU(i) must contain the scalar factor of the elementary
*>          reflector H(i), as returned by CGEQLF.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is COMPLEX array, dimension (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0: successful exit
*>          < 0: if INFO = -i, the i-th argument has an illegal value
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complexOTHERcomputational
*
*  =====================================================================
      SUBROUTINE CUNG2L( M, N, K, A, LDA, TAU, WORK, INFO )
*
*  -- LAPACK computational routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            INFO, K, LDA, M, N
*     ..
*     .. Array Arguments ..
      COMPLEX            A( LDA, * ), TAU( * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX            ONE, ZERO
      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ),
     $                   ZERO = ( 0.0E+0, 0.0E+0 ) )
*     ..
*     .. Local Scalars ..
      INTEGER            I, II, J, L
*     ..
*     .. External Subroutines ..
      EXTERNAL           CLARF, CSCAL, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
         INFO = -2
      ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CUNG2L', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.LE.0 )
     $   RETURN
*
*     Initialise columns 1:n-k to columns of the unit matrix
*
      DO 20 J = 1, N - K
         DO 10 L = 1, M
            A( L, J ) = ZERO
   10    CONTINUE
         A( M-N+J, J ) = ONE
   20 CONTINUE
*
      DO 40 I = 1, K
         II = N - K + I
*
*        Apply H(i) to A(1:m-k+i,1:n-k+i) from the left
*
         A( M-N+II, II ) = ONE
         CALL CLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A,
     $               LDA, WORK )
         CALL CSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 )
         A( M-N+II, II ) = ONE - TAU( I )
*
*        Set A(m-k+i+1:m,n-k+i) to zero
*
         DO 30 L = M - N + II + 1, M
            A( L, II ) = ZERO
   30    CONTINUE
   40 CONTINUE
      RETURN
*
*     End of CUNG2L
*
      END


program mem_alignment
  use iso_fortran_env, only : real32, real64
  implicit none

  integer, parameter :: n = 2048
  integer :: i,k = 1
  real(real32),dimension(n) :: a, b
  real(real32),allocatable :: a_a(:), a_b(:)
  !dir$ attributes align:64 :: a_a, a_b

  real(real32) :: tmp, rec, c
  real(real64) :: time_Start, time_end
  integer :: j, iter=10000000, ierr

  rec = 1/n
  c = 0.0

  call cpu_time(time_start)

  do j=1,iter
    do i = 1, n
       a(i) = 1.0 - 3.1415 + 2*(n - i + 1.0) * rec + c
       b(i) = 2.0 + 6.283 + 5*(n - i + 1.0) + c
    end do
    c = c + 1
  end do

  call cpu_time(time_end)

  write(*,*) a(10), 'TIme:',time_end - time_start

  ! allocate(a_a(n),a_b(n))
  ! c = 0.0

  ! call cpu_time(time_start)

  ! do j = 1,iter
  !    do i = 1, n
  !       a_a(i) = 1.0 - 3.1415 + 2*( n - i + 1.0) * rec + c
  !       a_b(i) = 2.0 + 6.283 + 5*(n - i + 1.0) + c
  !    end do
  !   c = c + 1
  ! end do

  ! call cpu_time(time_end)

  ! write(*,*) a_a(10), 'TIme:',time_end - time_start

!To be commented when explaining vectorization
  ! do j = 1,iter
  !    do i = 1, n-1
  !       a(i) = 1.0 - 3.1415 + 2*( n - i + 1.0_real64) * rec
  !       a(i) = 2.0 + 6.283 + 5*(n - i + 1.0_real64)
  !    end do
  ! end do

end program mem_alignment


// exercise 11.2.1

u=(); U=(); UU=()-> ();
t = fix (\t:Nat->U. \n:Nat.
    if iszero n
        then (\x:U. x) u
        else (\f:UU. f(f(u))) (\x:U. t(pred n))
    );

t 2;
(t 15; t 2);


program test_associate
implicit none
integer :: i
associate (a => 2.0, b => 2.0, c => -12.0) ! 2*x^2 + 2*x - 12 = 0
associate (discrim => b**2 - 4*a*c, denom => 2*a)
if (discrim < 0.0 .or. a == 0.0) stop "need discrim >= 0 and a /= 0.0"
! because r1, r2 depend on discrim and denom, they need a separate ASSOCIATE
associate (r1 => (-b + sqrt(discrim))/denom, r2 => (-b - sqrt(discrim))/denom)
print*,"coefficients =",a,b,c
print*,"roots =",r1,r2 ! 2.00000000 -3.00000000
end associate ; end associate ; end associate
pow: associate (powers => [0.5,0.33,0.25]) ! ASSOCIATE block can be named
print "(/,a8,*(f8.4))","power",powers
do i=2,4
   associate (x => real(i))
   print "(i8,*(f8.4))",i,x**powers
   end associate ! matching END ASSOCIATE needed for ASSOCIATE in loop
end do
end associate pow ! If ASSOCIATE named, END ASSOCIATE must have matching name
end program test_associate
! output:
!  coefficients =   2.00000000       2.00000000      -12.0000000
!  roots =   2.00000000      -3.00000000
!
!    power  0.5000  0.3300  0.2500
!        2  1.4142  1.2570  1.1892
!        3  1.7321  1.4370  1.3161
!        4  2.0000  1.5801  1.4142


! Program to test the SIZE intrinsics
program testsize
   implicit none
   real, dimension(:, :), allocatable :: a
   integer, dimension(5) :: j
   integer, dimension(2, 3) :: b
   integer i

   if (size (b(2, :), 1) .ne. 3) call abort

   allocate (a(3:8, 5:7))

   ! With one parameter
   if (size(a) .ne. 18) call abort

   ! With two parameters, assigning to an array
   j = size(a, 1)
   if (any (j .ne. (/6, 6, 6, 6, 6/))) call abort

   ! With a variable second parameter
   i = 2
   i = size(a, i)
   if (i .ne. 3) call abort

   call test(a)
contains

subroutine test (a)
   real, dimension (1:, 1:) :: a
   integer i

   i = 2
   if ((size(a, 1) .ne. 6) .or. (size(a, i) .ne. 3)) call abort
   if (size (a) .ne. 18 ) call abort
end subroutine
end program


! plot.f90
!
! Example web application that returns a plot in PNG format of the
! Lotka-Volterra ODEs, solved using the Runge-Kutta 4th order method.
!
! The initial population sizes of predator and prey species are passed by the
! HTTP GET parameters `u` and `v`:
!
!     http://localhost/plot.png?u=5&v=20
!
! The min. (1) and max. (50) values for both parameters are hard-coded.
!
! Be aware that the DISLIN library `./lib/dislin-*.a` must have been compiled
! with flag `-fPIC`!!
!
! Equations:
!
!     u(t) >= 0     -   Population size of prey at time t.
!     v(t) >= 0     -   Population size of predator at time t.
!
!     d/dt u = u * (alpha - beta * v)
!     d/dt v = -v * (gamma - delta * u)
!
! Model Parameters:
!
!     u             -   Prey population.
!     v             -   Predator population.
!     alpha         -   Reproduction rate of prey.
!     beta          -   Death rate of prey by predator.
!     gamma         -   Death rate of predator.
!     delta         -   Reproduction rate of predator by prey.
!
! Author:  Philipp Engel
! Licence: ISC
module plot
    use, intrinsic :: iso_c_binding,   only: c_null_char
    use, intrinsic :: iso_fortran_env, only: compiler_version, wp => real32
    use :: ngx_link_func
    implicit none
    private

    ! Point estimates for model parameters, taken from:
    !     https://www.math.tamu.edu/~phoward/m442/modbasics.pdf
    real(kind=wp), parameter :: ALPHA = 0.470_wp
    real(kind=wp), parameter :: BETA  = 0.024_wp
    real(kind=wp), parameter :: DELTA = 0.023_wp
    real(kind=wp), parameter :: GAMMA = 0.760_wp

    logical, save :: is_service_on = .false.

    public :: ngx_plot
    public :: ngx_link_func_exit_cycle
    public :: ngx_link_func_init_cycle
contains
    function rk4(r, t, h)
        !! Runge-Kutta 4th order solver.
        real(kind=wp), intent(in) :: r(2)   ! Initial values.
        real(kind=wp), intent(in) :: t      ! Step.
        real(kind=wp), intent(in) :: h      ! Step size.
        real(kind=wp)             :: rk4(2)
        real(kind=wp)             :: k1(2), k2(2), k3(2), k4(2)

        k1 = h * f(r,            t)
        k2 = h * f(r + 0.5 * k1, t + 0.5 * h)
        k3 = h * f(r + 0.5 * k2, t + 0.5 * h)
        k4 = h * f(r + k3,       t + h)

        rk4 = (k1 + (2 * k2) + (2 * k3) + k4) / 6
    end function rk4

    function f(r, t)
        !! The Lotka-Volterra ODEs.
        real(kind=wp), intent(in) :: r(2)
        real(kind=wp), intent(in) :: t
        real(kind=wp)             :: f(2)
        real(kind=wp)             :: u, v

        u = r(1)
        v = r(2)

        f(1) =  u * (ALPHA - BETA * v)
        f(2) = -v * (GAMMA - DELTA * u)
    end function f

    subroutine ngx_link_func_exit_cycle(cyc) bind(c)
        type(ngx_link_func_cycle_t), intent(in) :: cyc

        call ngx_link_func_cyc_log_info(cyc, 'Shutting down the web app ...' // c_null_char)
        is_service_on = .false.
    end subroutine ngx_link_func_exit_cycle

    subroutine ngx_link_func_init_cycle(cyc) bind(c)
        type(ngx_link_func_cycle_t), intent(in) :: cyc

        call ngx_link_func_cyc_log_info(cyc, 'Starting the web app ...' // c_null_char)
        is_service_on = .true.
    end subroutine ngx_link_func_init_cycle

    subroutine ngx_plot(ctx) bind(c)
        real(kind=wp), parameter              :: T_MAX = 50.0_wp
        real(kind=wp), parameter              :: H     = 0.01_wp
        integer,       parameter              :: N     = T_MAX / H
        type(ngx_link_func_ctx_t), intent(in) :: ctx
        character(len=:), allocatable         :: png
        character(len=:), allocatable         :: u, v
        integer                               :: i, rc
        real(kind=wp)                         :: t(N)  = [ (H * i, i = 1, N) ]
        real(kind=wp)                         :: r(2)
        real(kind=wp)                         :: x(N), y(N)

        ! Initial prey population.
        u = ngx_link_func_get_query_param(ctx, 'u' // c_null_char)
        ! Initial predator population.
        v = ngx_link_func_get_query_param(ctx, 'v' // c_null_char)

        read (u, *, iostat=rc) r(1)
        read (v, *, iostat=rc) r(2)

        r(1) = min(50, max(1, int(r(1))))
        r(2) = min(50, max(1, int(r(2))))

        ! Solve ODEs.
        do i = 1, N
            x(i) = r(1)
            y(i) = r(2)
            r = r + rk4(r, t(i), H)
        end do

        call plot_curves(t, x, y, N, T_MAX, png)
        call ngx_link_func_write_resp(ctx, &
                                      int(200, kind=8), &
                                      '200 OK' // c_null_char, &
                                      'image/png' // c_null_char, &
                                      png // c_null_char, &
                                      int(len(png), kind=8))
        deallocate (png)
    end subroutine ngx_plot

    subroutine plot_curves(t, x, y, n, t_max, png)
        !! Plotting routine that calls DISLIN and returns the rendered PNG image
        !! in `png`.
        use :: dislin
        integer,                       intent(in)    :: n
        real(kind=wp),                 intent(inout) :: t(n)
        real(kind=wp),                 intent(inout) :: x(n)
        real(kind=wp),                 intent(inout) :: y(n)
        real(kind=wp),                 intent(in)    :: t_max
        character(len=:), allocatable, intent(inout) :: png
        character(len=80)                            :: leg
        character(len=80)                            :: sub
        character(len=80)                            :: lab
        integer                                      :: dt(8)
        integer                                      :: bs, c, m
        real                                         :: dv

        ! Set DISLIN output.
        call metafl('virt')
        call scrmod('revers')
        call winsiz(1024, 768)
        call imgfmt('rgb')

        ! Initialise DISLIN.
        call disini()
        call errmod('all', 'off')   ! Disable console output.
        call texmod('on')           ! Enable TeX features.
        call simplx()               ! Load single stroke font.

        ! Set title and sub-title.
        call titlin('Lotka-Volterra Equations', 1)
        write (sub, '(4(a, f5.3))') '$\alpha$ = ', ALPHA, &
                                    ', $\beta$ = ', BETA, &
                                    ', $\delta$ = ', DELTA, &
                                    ', $\gamma$ = ', GAMMA
        call titlin(trim(sub), 3)

        ! Set bottom label.
        call date_and_time(values=dt)
        call getver(dv)
        write (lab, '(i4, 5(a, i2.2), 3a, f4.1)') &
            dt(1), '/', dt(2), '/', dt(3), ' ', dt(5), ':', dt(6), ':', dt(7), &
            ', ', compiler_version(), ', DISLIN ', dv
        call messag(trim(lab), 100, 2000)

        ! Set axis.
        call name('Time', 'X')
        call name('Population Size', 'Y')

        call labdig(-1, 'X')
        call ticks(10, 'XY')

        c = intrgb(.95, .95, .95)
        call axsbgd(c)

        ! Set plot limits and grid.
        call graf(0., t_max, 0., 10., 0., 300., 0., 50.)
        call setrgb(.7, .7, .7)
        call grid(1, 1)

        ! Show title.
        call color('fore')
        call title()

        ! Plot curves.
        call color('red')
        call curve(t, x, n)

        call color('green')
        call curve(t , y, n)

        ! Show legend.
        call color('fore')
        call legini(leg, 2, 8)
        call legtit(' ')
        call leglin(leg, 'Prey', 1)
        call leglin(leg, 'Predator', 2)
        call legend(leg, 7)

        ! Copy raw PNG to buffer.
        call rbfpng(png, 0, bs)
        if (allocated(png)) deallocate (png)
        allocate (character(len=bs) :: png)
        call rbfpng(png, bs, m)

        ! Clean up.
        call disfin()
    end subroutine plot_curves
end module plot


!
! The Laboratory of Algorithms
!
! The MIT License
!
! Copyright 2011-2015 Andrey Pudov.
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the 'Software'), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in
! all copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
!

module MFCircle

    use MFShape

    implicit none
    private

    type, extends(TFShape), public :: TFCircle
    contains
        procedure :: getArea
    end type

    interface TFCircle
        module procedure init
    end interface
contains
    function init(radius) result(circle)
        real, intent(in) :: radius
        type(TFCircle)   :: circle

        circle%width = radius
    end function

    function getArea(this) result(area)
        class(TFCircle), intent(in) :: this
        real :: area

        area = this%width * this%width * 3.14159265 / 4.0
    end function
end module


        SUBROUTINE calc_hoh_pot(x, nwalk, v)
        implicit real*8 (a-h,o-z)

        parameter (natom = 3)
        parameter (ndim = 3*natom)
        integer, intent(in) :: nwalk
        double precision, dimension(nwalk,natom,3), intent(in) :: x
        double precision, dimension (nwalk), intent(out) :: v

        dimension rij(nwalk,3)

        do k = 1,nwalk

           r1 = 0.
           r2 = 0.
           ct = 0.
           do j = 1,3
              d1 = x(k,3,j)-x(k,1,j)
              d2 = x(k,3,j)-x(k,2,j)
              r1 = r1 + d1**2
              r2 = r2 + d2**2
              ct = ct + d1*d2
           enddo
           rij(k,1) = sqrt(r1)
           rij(k,2) = sqrt(r2)
           rij(k,3) = acos(CT/rij(k,1)/rij(k,2))

        enddo

        call vibpot(rij,v,nwalk)

        end


SUBROUTINE p75(input_file,output_file)
!-------------------------------------------------------------------------
! SUBROUTINE 7.5 General two- (plane) or three-dimensional analysis of steady
!             seepage. No global conductivity matrix assembly.
!             Diagonally preconditioned conjugate gradient solver.
!-------------------------------------------------------------------------
 USE main;
 USE geom;
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::cg_iters,cg_limit,fixed_freedoms,i,iel,k,loaded_nodes,nci,ndim, &
   nels,neq,nip,nlen,nod,nn,np_types
 REAL(iwp)::alpha,beta,cg_tol,det,one=1.0_iwp,penalty=1.0e20_iwp,up,      &
   zero=0.0_iwp
 CHARACTER(LEN=15)::argv,element;
 LOGICAL::cg_converged
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g_num(:,:),node(:),num(:)
 REAL(iwp),ALLOCATABLE::coord(:,:),d(:),der(:,:),deriv(:,:),              &
   diag_precon(:),disps(:),g_coord(:,:),jac(:,:),kay(:,:),kp(:,:),        &
   loads(:),p(:),points(:,:),prop(:,:),store(:),storkp(:,:,:),u(:),       &
   value(:),weights(:),x(:),xnew(:)
!-----------------------input and initialisation--------------------------

 OPEN(10,FILE=input_file);
 OPEN(11,FILE=output_file)
 READ(10,*)element,nod,nels,nn,nip,ndim,cg_tol,cg_limit,np_types;
 neq=nn
 WRITE(11,'(A,I5,A)')" There are",neq," equations"
 ALLOCATE(points(nip,ndim),g_coord(ndim,nn),coord(nod,ndim),etype(nels),  &
   jac(ndim,ndim),weights(nip),num(nod),g_num(nod,nels),der(ndim,nod),    &
   deriv(ndim,nod),kp(nod,nod),kay(ndim,ndim),prop(ndim,np_types),        &
   p(0:neq),loads(0:neq),x(0:neq),xnew(0:neq),u(0:neq),diag_precon(0:neq),&
   d(0:neq),disps(0:neq),storkp(nod,nod,nels))
 READ(10,*)prop;
 etype=1;
 IF(np_types>1)READ(10,*)etype;
 READ(10,*)g_coord
 READ(10,*)g_num;
 IF(ndim==2)CALL mesh(g_coord,g_num,argv,nlen,12)
 diag_precon=zero;
 CALL sample(element,points,weights)
!----------element conductivity integration, storage and preconditioner---
 elements_1: DO iel=1,nels
   kay=zero;
   DO i=1,ndim;
     kay(i,i)=prop(i,etype(iel));
   END DO
   num=g_num(:,iel);
   coord=TRANSPOSE(g_coord(:,num));
   kp=zero
   gauss_pts_1: DO i=1,nip
     CALL shape_der(der,points,i);
     jac=MATMUL(der,coord)
     det=determinant(jac);
     CALL invert(jac);
     deriv=MATMUL(jac,der)
     kp=kp+MATMUL(MATMUL(TRANSPOSE(deriv),kay),deriv)*det*weights(i)
   END DO gauss_pts_1;
   storkp(:,:,iel)=kp
   DO k=1,nod;
     diag_precon(num(k))=diag_precon(num(k))+kp(k,k);
   END DO
 END DO elements_1
!-----------------------invert the preconditioner and get starting loads--
 loads=zero;
 READ(10,*)loaded_nodes,(k,loads(k),i=1,loaded_nodes)
 READ(10,*)fixed_freedoms
 IF(fixed_freedoms/=0)THEN
   ALLOCATE(node(fixed_freedoms),value(fixed_freedoms),                   &
     store(fixed_freedoms))
   READ(10,*)(node(i),value(i),i=1,fixed_freedoms)
   diag_precon(node)=diag_precon(node)+penalty
   loads(node)=diag_precon(node)*value;
   store=diag_precon(node)
 END IF
 diag_precon(1:)=one/diag_precon(1:);
 diag_precon(0)=zero
 d=diag_precon*loads;
 p=d;
 x=zero;
 cg_iters=0
 !-----------------------pcg equation solution-----------------------------
 pcg: DO
   cg_iters=cg_iters+1;
   u=zero
   elements_2: DO iel=1,nels
     num=g_num(:,iel);
     kp=storkp(:,:,iel);
     u(num)=u(num)+MATMUL(kp,p(num))
   END DO elements_2
   IF(fixed_freedoms/=0)u(node)=p(node)*store;
   up=DOT_PRODUCT(loads,d)
   alpha=up/DOT_PRODUCT(p,u);
   xnew=x+p*alpha;
   loads=loads-u*alpha
   d=diag_precon*loads;
   beta=DOT_PRODUCT(loads,d)/up;
   p=d+p*beta
   CALL checon(xnew,x,cg_tol,cg_converged)
   IF(cg_converged.OR.cg_iters==cg_limit)EXIT
 END DO pcg
 WRITE(11,'(A,I5)')" Number of cg iterations to convergence was",cg_iters
!-----------------------retrieve nodal net flow rates---------------------
 loads=xnew;
 disps=zero
 elements_3: DO iel=1,nels
   num=g_num(:,iel);
   kp=storkp(:,:,iel)
   disps(num)=disps(num)+MATMUL(kp,loads(num))
 END DO elements_3;
 disps(0)=zero
 WRITE(11,'(/A)')"  Node Total Head  Flow rate"
 DO k=1,nn;
   WRITE(11,'(I5,2E12.4)')k,loads(k),disps(k);
 END DO
 WRITE(11,'(/A)')"       Inflow      Outflow"
 WRITE(11,'(5X,2E12.4)')                                                  &
   SUM(disps,MASK=disps>zero),SUM(disps,MASK=disps<zero)
 IF(ndim==2.AND.nod==4)THEN
   READ(10,*)nci;
   CALL contour(loads,g_coord,g_num,nci,argv,nlen,13)
 END IF

END SUBROUTINE p75


module init_fluid_module

      use amrex_fort_module, only: rt => amrex_real
      use iso_c_binding,     only: c_int

contains
!vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv!
!                                                                      !
!  Subroutine: init_fluid                                              !
!                                                                      !
!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^!
   subroutine init_fluid(slo, shi, lo, hi, &
                         domlo, domhi, ro, p, vel, eta, &
                         dx, dy, dz, xlength, ylength, zlength, probtype) &
      bind(C, name="init_fluid")

      use constant, only: ro_0, mu
      use constant, only: ic_u, ic_v, ic_w

      implicit none

! Dummy arguments .....................................................//
      integer(c_int), intent(in   ) ::  lo(3),  hi(3)
      integer(c_int), intent(in   ) :: slo(3), shi(3)
      integer(c_int), intent(in   ) :: domlo(3),domhi(3)

      real(rt), intent(inout) ::  ro(slo(1):shi(1), slo(2):shi(2), slo(3):shi(3)  )
      real(rt), intent(inout) ::   p(slo(1):shi(1), slo(2):shi(2), slo(3):shi(3)  )
      real(rt), intent(inout) :: vel(slo(1):shi(1), slo(2):shi(2), slo(3):shi(3),3)
      real(rt), intent(inout) :: eta(slo(1):shi(1), slo(2):shi(2), slo(3):shi(3)  )

      real(rt), intent(in   ) :: dx, dy, dz
      real(rt), intent(in   ) :: xlength, ylength, zlength
      integer,  intent(in   ) :: probtype

      ! Set the initial fluid density and viscosity
      ro  = ro_0
      eta = mu
      vel(:,:,:,1) = ic_u
      vel(:,:,:,2) = ic_v
      vel(:,:,:,3) = ic_w

      if (probtype == 1) call taylor_green(lo, hi, vel, slo, shi, dx, dy, dz, domlo)
      if (probtype == 2) call double_shear_layer(lo, hi, vel, slo, shi, dx, dy, dz, domlo)
      if (probtype == 31 .or. probtype == 32 .or. probtype == 33)  &
         call plane_poiseuille(lo, hi, vel, slo, shi, dx, dy, dz, domlo, domhi, probtype)
      if (probtype == 4) call couette(lo, hi, vel, slo, shi, dx, dy, dz, domlo, domhi)

   end subroutine init_fluid

   subroutine taylor_green(lo, hi, vel, slo, shi, dx, dy, dz, domlo)

      use constant, only: zero, half, one

      implicit none

      ! Array bounds
      integer(c_int), intent(in   ) :: lo(3), hi(3)
      integer(c_int), intent(in   ) :: domlo(3)
      integer(c_int), intent(in   ) :: slo(3), shi(3)

      ! Arrays
      real(rt),       intent(inout) :: vel(slo(1):shi(1),slo(2):shi(2),slo(3):shi(3),3)

      real(rt),       intent(in   ) :: dx, dy, dz

      ! Local variables
      integer(c_int)                  :: i, j, k
      real(rt)                        :: x, y, z
      real(rt)                        :: twopi = 8.0_rt * atan(one)

      ! x-direction
      do j = lo(2), hi(2)
         y =  ( real(j,rt) + half ) * dy
         do i = lo(1), hi(1)
            x =  ( real(i,rt) + half ) * dx
            do k = lo(3), hi(3)
               vel(i,j,k,1) =  sin(twopi * x) * cos(twopi * y)
               vel(i,j,k,2) = -cos(twopi * x) * sin(twopi * y)
               vel(i,j,k,3) = zero
            end do
         end do
      end do

   end subroutine taylor_green

   subroutine double_shear_layer(lo, hi, vel, slo, shi, dx, dy, dz, domlo)

      use constant, only: zero, half, one

      implicit none

      ! Array bounds
      integer(c_int), intent(in   ) :: lo(3), hi(3)
      integer(c_int), intent(in   ) :: domlo(3)
      integer(c_int), intent(in   ) :: slo(3), shi(3)

      ! Arrays
      real(rt),       intent(inout) :: vel(slo(1):shi(1),slo(2):shi(2),slo(3):shi(3),3)

      real(rt),       intent(in   ) :: dx, dy, dz

      ! Local variables
      integer(c_int)                :: i, j, k, plane
      real(rt)                      :: x, y, z
      real(rt)                      :: twopi = 8.0_rt * atan(one)

      plane = 1

      select case ( plane )

      case (1)  ! x-y plane

         ! x-direction
         do j = lo(2), hi(2)
            y =  ( real(j,rt) + half ) * dy
            do i = lo(1), hi(1)
               x =  ( real(i,rt) + half ) * dx
               do k = lo(3), hi(3)
                  vel(i,j,k,1) = tanh ( 30.0_rt * (0.25_rt - abs ( y - 0.5_rt ) ) )
                  vel(i,j,k,2) = 0.05_rt * sin ( twopi * x )
                  vel(i,j,k,3) = zero
               end do
            end do
         end do

      case (2)  ! x-z plane

         ! x-direction
         do k = lo(3), hi(3)
            z =  ( real(k,rt) + half ) * dz
            do i = lo(1), hi(1)
               x =  ( real(i,rt) + half ) * dx
               do j = lo(2), hi(2)
                  vel(i,j,k,1) = tanh ( 30.0_rt * (0.25_rt - abs ( z - 0.5_rt ) ) )
                  vel(i,j,k,2) = zero
                  vel(i,j,k,3) = 0.05_rt * sin ( twopi * x )
               end do
            end do
         end do

      case (3)  ! y-z plane

         ! x-direction
         do k = lo(3), hi(3)
            z =  ( real(k,rt) + half ) * dz
            do j = lo(2), hi(2)
               y =  ( real(j,rt) + half ) * dy
               do i = lo(1), hi(1)
                  vel(i,j,k,1) = zero
                  vel(i,j,k,2) = tanh ( 30.0_rt * (0.25_rt - abs ( z - 0.5_rt ) ) )
                  vel(i,j,k,3) = 0.05_rt * sin ( twopi * y )
               end do
            end do
         end do

      end select

   end subroutine double_shear_layer

   subroutine plane_poiseuille(lo, hi, vel, slo, shi, dx, dy, dz, domlo, domhi, probtype)

      use constant, only: ic_u, ic_v, ic_w

      implicit none

      integer(c_int),   intent(in   ) ::    lo(3),    hi(3)
      integer(c_int),   intent(in   ) :: domlo(3), domhi(3)
      integer(c_int),   intent(in   ) ::   slo(3),   shi(3)
      integer(c_int),   intent(in   ) :: probtype

      real(rt),         intent(in   ) :: dx, dy, dz
      real(rt),         intent(inout) :: vel(slo(1):shi(1), slo(2):shi(2), slo(3):shi(3), 3)

      ! Local variables
      integer(c_int)                  :: i, j, k
      integer(c_int)                  :: num_cells
      real(rt)                        :: x, y, z

      if (probtype .eq. 31) then

         num_cells = domhi(2) - domlo(2) + 1

         do k = lo(3), hi(3)
         do j = lo(2), hi(2)
            do i = lo(1), hi(1)
               y =  (real(j,rt) + 0.5) / num_cells
               vel(i,j,k,1) = 6.0 * ic_u * y * (1.0 - y)
               vel(i,j,k,2) = 0.0
               vel(i,j,k,3) = 0.0
            end do
         end do
         end do

      else if (probtype .eq. 32) then

         num_cells = domhi(3) - domlo(3) + 1

         do k = lo(3), hi(3)
         do j = lo(2), hi(2)
            do i = lo(1), hi(1)
               z =  (real(k,rt) + 0.5) / num_cells
               vel(i,j,k,1) = 0.0
               vel(i,j,k,2) = 6.0 * ic_v * z * (1.0 - z)
               vel(i,j,k,3) = 0.0
            end do
         end do
         end do

      else if (probtype .eq. 33) then

         num_cells = domhi(1) - domlo(1) + 1

         do k = lo(3), hi(3)
         do j = lo(2), hi(2)
            do i = lo(1), hi(1)
               x =  (real(i,rt) + 0.5) / num_cells
               vel(i,j,k,1) = 0.0
               vel(i,j,k,2) = 0.0
               vel(i,j,k,3) = 6.0 * ic_w * x * (1.0 - x)
            end do
         end do
         end do

      else
          print *,'Dont know this probtype in plane_poiseuille: ', probtype
          stop
      end if

   end subroutine plane_poiseuille

   subroutine couette(lo, hi, vel, slo, shi, dx, dy, dz, domlo, domhi)

      use constant,          only: zero, half, one
      use constant,          only: ic_u

      implicit none

      integer(c_int),   intent(in   ) ::    lo(3),    hi(3)
      integer(c_int),   intent(in   ) :: domlo(3), domhi(3)
      integer(c_int),   intent(in   ) ::   slo(3),   shi(3)

      real(rt),         intent(inout) :: vel(slo(1):shi(1), slo(2):shi(2), slo(3):shi(3), 3)

      real(rt),         intent(in   ) :: dx, dy, dz

      ! Local variables
      integer(c_int)                  :: i, j, k
      integer(c_int)                  :: num_cells_y
      real(rt)                        :: y

      num_cells_y = domhi(2) - domlo(2) + 1

      do k = lo(3), hi(3)
         do j = lo(2), hi(2)
            y =  (real(j,rt) + half) / num_cells_y
            do i = lo(1), hi(1)
               vel(i,j,k,1) = ic_u * (y - half)
               vel(i,j,k,2) = zero
               vel(i,j,k,3) = zero
            end do
         end do
      end do

   end subroutine couette

end module init_fluid_module


c*************************************************************************
c                        DRIFT_KEPU_STUMPFF.F
c*************************************************************************
c subroutine for the calculation of stumpff functions
c see Danby p.172  equations 6.9.15
c
c             Input:
c                 x             ==>  argument
c             Output:
c                 c0,c1,c2,c3   ==>  c's from p171-172
c                                       (real scalors)
c Author:  Hal Levison
c Date:    2/3/93
c Last revision: 2/3/93

      subroutine drift_kepu_stumpff(x,c0,c1,c2,c3)

      include '../../swift.inc'

c...  Inputs:
      real*8 x

c...  Outputs:
      real*8 c0,c1,c2,c3

c...  Internals:
      integer n,i
      real*8 xm

c----
c...  Executable code

      n = 0
      xm = 0.1
      do while(abs(x).ge.xm)
         n = n + 1
         x = x/4.0
      enddo

      c2 = (1.-x*(1.-x*(1.-x*(1.-x*(1.-x*(1.-x/182.)
     &       /132.)/90.)/56.)/30.)/12.)/2.
      c3 = (1.-x*(1.-x*(1.-x*(1.-x*(1.-x*(1.-x/210.)
     &       /156.)/110.)/72.)/42.)/20.)/6.
      c1 = 1. - x*c3
      c0 = 1. - x*c2

      if(n.ne.0) then
         do i=n,1,-1
            c3 = (c2 + c0*c3)/4.
            c2 = c1*c1/2.
            c1 = c0*c1
            c0 = 2.*c0*c0 - 1.
            x = x * 4.
          enddo
       endif

       return
       end     !   drift_kepu_stumpff
c------------------------------------------------------------------


      SUBROUTINE LINTPT (A,B,C, D,E,F, X,Y)

C Given two sets of line-coefficients, find intersection point

      REAL  A,B,C,D,E,F,X,Y, DEN

      DEN = D*B - A*E
      X = (C*E - F*B) / DEN
      Y = (F*A - C*D) / DEN

      END


      subroutine clocur(iopt,ipar,idim,m,u,mx,x,w,k,s,nest,n,t,nc,c,fp,
     * wrk,lwrk,iwrk,ier)
c  given the ordered set of m points x(i) in the idim-dimensional space
c  with x(1)=x(m), and given also a corresponding set of strictly in-
c  creasing values u(i) and the set of positive numbers w(i),i=1,2,...,m
c  subroutine clocur determines a smooth approximating closed spline
c  curve s(u), i.e.
c      x1 = s1(u)
c      x2 = s2(u)       u(1) <= u <= u(m)
c      .........
c      xidim = sidim(u)
c  with sj(u),j=1,2,...,idim periodic spline functions of degree k with
c  common knots t(j),j=1,2,...,n.
c  if ipar=1 the values u(i),i=1,2,...,m must be supplied by the user.
c  if ipar=0 these values are chosen automatically by clocur as
c      v(1) = 0
c      v(i) = v(i-1) + dist(x(i),x(i-1)) ,i=2,3,...,m
c      u(i) = v(i)/v(m) ,i=1,2,...,m
c  if iopt=-1 clocur calculates the weighted least-squares closed spline
c  curve according to a given set of knots.
c  if iopt>=0 the number of knots of the splines sj(u) and the position
c  t(j),j=1,2,...,n is chosen automatically by the routine. the smooth-
c  ness of s(u) is then achieved by minimalizing the discontinuity
c  jumps of the k-th derivative of s(u) at the knots t(j),j=k+2,k+3,...,
c  n-k-1. the amount of smoothness is determined by the condition that
c  f(p)=sum((w(i)*dist(x(i),s(u(i))))**2) be <= s, with s a given non-
c  negative constant, called the smoothing factor.
c  the fit s(u) is given in the b-spline representation and can be
c  evaluated by means of subroutine curev.
c
c  calling sequence:
c     call clocur(iopt,ipar,idim,m,u,mx,x,w,k,s,nest,n,t,nc,c,
c    * fp,wrk,lwrk,iwrk,ier)
c
c  parameters:
c   iopt  : integer flag. on entry iopt must specify whether a weighted
c           least-squares closed spline curve (iopt=-1) or a smoothing
c           closed spline curve (iopt=0 or 1) must be determined. if
c           iopt=0 the routine will start with an initial set of knots
c           t(i)=u(1)+(u(m)-u(1))*(i-k-1),i=1,2,...,2*k+2. if iopt=1 the
c           routine will continue with the knots found at the last call.
c           attention: a call with iopt=1 must always be immediately
c           preceded by another call with iopt=1 or iopt=0.
c           unchanged on exit.
c   ipar  : integer flag. on entry ipar must specify whether (ipar=1)
c           the user will supply the parameter values u(i),or whether
c           (ipar=0) these values are to be calculated by clocur.
c           unchanged on exit.
c   idim  : integer. on entry idim must specify the dimension of the
c           curve. 0 < idim < 11.
c           unchanged on exit.
c   m     : integer. on entry m must specify the number of data points.
c           m > 1. unchanged on exit.
c   u     : real array of dimension at least (m). in case ipar=1,before
c           entry, u(i) must be set to the i-th value of the parameter
c           variable u for i=1,2,...,m. these values must then be
c           supplied in strictly ascending order and will be unchanged
c           on exit. in case ipar=0, on exit,the array will contain the
c           values u(i) as determined by clocur.
c   mx    : integer. on entry mx must specify the actual dimension of
c           the array x as declared in the calling (sub)program. mx must
c           not be too small (see x). unchanged on exit.
c   x     : real array of dimension at least idim*m.
c           before entry, x(idim*(i-1)+j) must contain the j-th coord-
c           inate of the i-th data point for i=1,2,...,m and j=1,2,...,
c           idim. since first and last data point must coincide it
c           means that x(j)=x(idim*(m-1)+j),j=1,2,...,idim.
c           unchanged on exit.
c   w     : real array of dimension at least (m). before entry, w(i)
c           must be set to the i-th value in the set of weights. the
c           w(i) must be strictly positive. w(m) is not used.
c           unchanged on exit. see also further comments.
c   k     : integer. on entry k must specify the degree of the splines.
c           1<=k<=5. it is recommended to use cubic splines (k=3).
c           the user is strongly dissuaded from choosing k even,together
c           with a small s-value. unchanged on exit.
c   s     : real.on entry (in case iopt>=0) s must specify the smoothing
c           factor. s >=0. unchanged on exit.
c           for advice on the choice of s see further comments.
c   nest  : integer. on entry nest must contain an over-estimate of the
c           total number of knots of the splines returned, to indicate
c           the storage space available to the routine. nest >=2*k+2.
c           in most practical situation nest=m/2 will be sufficient.
c           always large enough is nest=m+2*k, the number of knots
c           needed for interpolation (s=0). unchanged on exit.
c   n     : integer.
c           unless ier = 10 (in case iopt >=0), n will contain the
c           total number of knots of the smoothing spline curve returned
c           if the computation mode iopt=1 is used this value of n
c           should be left unchanged between subsequent calls.
c           in case iopt=-1, the value of n must be specified on entry.
c   t     : real array of dimension at least (nest).
c           on succesful exit, this array will contain the knots of the
c           spline curve,i.e. the position of the interior knots t(k+2),
c           t(k+3),..,t(n-k-1) as well as the position of the additional
c           t(1),t(2),..,t(k+1)=u(1) and u(m)=t(n-k),...,t(n) needed for
c           the b-spline representation.
c           if the computation mode iopt=1 is used, the values of t(1),
c           t(2),...,t(n) should be left unchanged between subsequent
c           calls. if the computation mode iopt=-1 is used, the values
c           t(k+2),...,t(n-k-1) must be supplied by the user, before
c           entry. see also the restrictions (ier=10).
c   nc    : integer. on entry nc must specify the actual dimension of
c           the array c as declared in the calling (sub)program. nc
c           must not be too small (see c). unchanged on exit.
c   c     : real array of dimension at least (nest*idim).
c           on succesful exit, this array will contain the coefficients
c           in the b-spline representation of the spline curve s(u),i.e.
c           the b-spline coefficients of the spline sj(u) will be given
c           in c(n*(j-1)+i),i=1,2,...,n-k-1 for j=1,2,...,idim.
c   fp    : real. unless ier = 10, fp contains the weighted sum of
c           squared residuals of the spline curve returned.
c   wrk   : real array of dimension at least m*(k+1)+nest*(7+idim+5*k).
c           used as working space. if the computation mode iopt=1 is
c           used, the values wrk(1),...,wrk(n) should be left unchanged
c           between subsequent calls.
c   lwrk  : integer. on entry,lwrk must specify the actual dimension of
c           the array wrk as declared in the calling (sub)program. lwrk
c           must not be too small (see wrk). unchanged on exit.
c   iwrk  : integer array of dimension at least (nest).
c           used as working space. if the computation mode iopt=1 is
c           used,the values iwrk(1),...,iwrk(n) should be left unchanged
c           between subsequent calls.
c   ier   : integer. unless the routine detects an error, ier contains a
c           non-positive value on exit, i.e.
c    ier=0  : normal return. the close curve returned has a residual
c             sum of squares fp such that abs(fp-s)/s <= tol with tol a
c             relative tolerance set to 0.001 by the program.
c    ier=-1 : normal return. the curve returned is an interpolating
c             spline curve (fp=0).
c    ier=-2 : normal return. the curve returned is the weighted least-
c             squares point,i.e. each spline sj(u) is a constant. in
c             this extreme case fp gives the upper bound fp0 for the
c             smoothing factor s.
c    ier=1  : error. the required storage space exceeds the available
c             storage space, as specified by the parameter nest.
c             probably causes : nest too small. if nest is already
c             large (say nest > m/2), it may also indicate that s is
c             too small
c             the approximation returned is the least-squares closed
c             curve according to the knots t(1),t(2),...,t(n). (n=nest)
c             the parameter fp gives the corresponding weighted sum of
c             squared residuals (fp>s).
c    ier=2  : error. a theoretically impossible result was found during
c             the iteration proces for finding a smoothing curve with
c             fp = s. probably causes : s too small.
c             there is an approximation returned but the corresponding
c             weighted sum of squared residuals does not satisfy the
c             condition abs(fp-s)/s < tol.
c    ier=3  : error. the maximal number of iterations maxit (set to 20
c             by the program) allowed for finding a smoothing curve
c             with fp=s has been reached. probably causes : s too small
c             there is an approximation returned but the corresponding
c             weighted sum of squared residuals does not satisfy the
c             condition abs(fp-s)/s < tol.
c    ier=10 : error. on entry, the input data are controlled on validity
c             the following restrictions must be satisfied.
c             -1<=iopt<=1, 1<=k<=5, m>1, nest>2*k+2, w(i)>0,i=1,2,...,m
c             0<=ipar<=1, 0<idim<=10, lwrk>=(k+1)*m+nest*(7+idim+5*k),
c             nc>=nest*idim, x(j)=x(idim*(m-1)+j), j=1,2,...,idim
c             if ipar=0: sum j=1,idim (x(i*idim+j)-x((i-1)*idim+j))**2>0
c                        i=1,2,...,m-1.
c             if ipar=1: u(1)<u(2)<...<u(m)
c             if iopt=-1: 2*k+2<=n<=min(nest,m+2*k)
c                         u(1)<t(k+2)<t(k+3)<...<t(n-k-1)<u(m)
c                            (u(1)=0 and u(m)=1 in case ipar=0)
c                       the schoenberg-whitney conditions, i.e. there
c                       must be a subset of data points uu(j) with
c                       uu(j) = u(i) or u(i)+(u(m)-u(1)) such that
c                         t(j) < uu(j) < t(j+k+1), j=k+1,...,n-k-1
c             if iopt>=0: s>=0
c                         if s=0 : nest >= m+2*k
c             if one of these conditions is found to be violated,control
c             is immediately repassed to the calling program. in that
c             case there is no approximation returned.
c
c  further comments:
c   by means of the parameter s, the user can control the tradeoff
c   between closeness of fit and smoothness of fit of the approximation.
c   if s is too large, the curve will be too smooth and signal will be
c   lost ; if s is too small the curve will pick up too much noise. in
c   the extreme cases the program will return an interpolating curve if
c   s=0 and the weighted least-squares point if s is very large.
c   between these extremes, a properly chosen s will result in a good
c   compromise between closeness of fit and smoothness of fit.
c   to decide whether an approximation, corresponding to a certain s is
c   satisfactory the user is highly recommended to inspect the fits
c   graphically.
c   recommended values for s depend on the weights w(i). if these are
c   taken as 1/d(i) with d(i) an estimate of the standard deviation of
c   x(i), a good s-value should be found in the range (m-sqrt(2*m),m+
c   sqrt(2*m)). if nothing is known about the statistical error in x(i)
c   each w(i) can be set equal to one and s determined by trial and
c   error, taking account of the comments above. the best is then to
c   start with a very large value of s ( to determine the weighted
c   least-squares point and the upper bound fp0 for s) and then to
c   progressively decrease the value of s ( say by a factor 10 in the
c   beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the
c   approximating curve shows more detail) to obtain closer fits.
c   to economize the search for a good s-value the program provides with
c   different modes of computation. at the first call of the routine, or
c   whenever he wants to restart with the initial set of knots the user
c   must set iopt=0.
c   if iopt=1 the program will continue with the set of knots found at
c   the last call of the routine. this will save a lot of computation
c   time if clocur is called repeatedly for different values of s.
c   the number of knots of the spline returned and their location will
c   depend on the value of s and on the complexity of the shape of the
c   curve underlying the data. but, if the computation mode iopt=1 is
c   used, the knots returned may also depend on the s-values at previous
c   calls (if these were smaller). therefore, if after a number of
c   trials with different s-values and iopt=1, the user can finally
c   accept a fit as satisfactory, it may be worthwhile for him to call
c   clocur once more with the selected value for s but now with iopt=0.
c   indeed, clocur may then return an approximation of the same quality
c   of fit but with fewer knots and therefore better if data reduction
c   is also an important objective for the user.
c
c   the form of the approximating curve can strongly be affected  by
c   the choice of the parameter values u(i). if there is no physical
c   reason for choosing a particular parameter u, often good results
c   will be obtained with the choice of clocur(in case ipar=0), i.e.
c        v(1)=0, v(i)=v(i-1)+q(i), i=2,...,m, u(i)=v(i)/v(m), i=1,..,m
c   where
c        q(i)= sqrt(sum j=1,idim (xj(i)-xj(i-1))**2 )
c   other possibilities for q(i) are
c        q(i)= sum j=1,idim (xj(i)-xj(i-1))**2
c        q(i)= sum j=1,idim abs(xj(i)-xj(i-1))
c        q(i)= max j=1,idim abs(xj(i)-xj(i-1))
c        q(i)= 1
c
c
c  other subroutines required:
c    fpbacp,fpbspl,fpchep,fpclos,fpdisc,fpgivs,fpknot,fprati,fprota
c
c  references:
c   dierckx p. : algorithms for smoothing data with periodic and
c                parametric splines, computer graphics and image
c                processing 20 (1982) 171-184.
c   dierckx p. : algorithms for smoothing data with periodic and param-
c                etric splines, report tw55, dept. computer science,
c                k.u.leuven, 1981.
c   dierckx p. : curve and surface fitting with splines, monographs on
c                numerical analysis, oxford university press, 1993.
c
c  author:
c    p.dierckx
c    dept. computer science, k.u. leuven
c    celestijnenlaan 200a, b-3001 heverlee, belgium.
c    e-mail : Paul.Dierckx@cs.kuleuven.ac.be
c
c  creation date : may 1979
c  latest update : march 1987
c
c  ..
c  ..scalar arguments..
      real s,fp
      integer iopt,ipar,idim,m,mx,k,nest,n,nc,lwrk,ier
c  ..array arguments..
      real u(m),x(mx),w(m),t(nest),c(nc),wrk(lwrk)
      integer iwrk(nest)
c  ..local scalars..
      real per,tol,dist
      integer i,ia1,ia2,ib,ifp,ig1,ig2,iq,iz,i1,i2,j1,j2,k1,k2,lwest,
     * maxit,m1,nmin,ncc,j
c  ..function references..
      real sqrt
c  we set up the parameters tol and maxit
      maxit = 20
      tol = 0.1e-02
c  before starting computations a data check is made. if the input data
c  are invalid, control is immediately repassed to the calling program.
      ier = 10
      if(iopt.lt.(-1) .or. iopt.gt.1) go to 90
      if(ipar.lt.0 .or. ipar.gt.1) go to 90
      if(idim.le.0 .or. idim.gt.10) go to 90
      if(k.le.0 .or. k.gt.5) go to 90
      k1 = k+1
      k2 = k1+1
      nmin = 2*k1
      if(m.lt.2 .or. nest.lt.nmin) go to 90
      ncc = nest*idim
      if(mx.lt.m*idim .or. nc.lt.ncc) go to 90
      lwest = m*k1+nest*(7+idim+5*k)
      if(lwrk.lt.lwest) go to 90
      i1 = idim
      i2 = m*idim
      do 5 j=1,idim
c   GH211017
c         if(x(i1).ne.x(i2)) go to 90
         if(abs(x(i1)-x(i2))<epsilon(x(i1))) go to 90
         i1 = i1-1
         i2 = i2-1
   5  continue
      if(ipar.ne.0 .or. iopt.gt.0) go to 40
      i1 = 0
      i2 = idim
      u(1) = 0.
      do 20 i=2,m
         dist = 0.
         do 10 j1=1,idim
            i1 = i1+1
            i2 = i2+1
            dist = dist+(x(i2)-x(i1))**2
  10     continue
         u(i) = u(i-1)+sqrt(dist)
  20  continue
      if(u(m).le.0.) go to 90
      do 30 i=2,m
         u(i) = u(i)/u(m)
  30  continue
      u(m) = 0.1e+01
  40  if(w(1).le.0.) go to 90
      m1 = m-1
      do 50 i=1,m1
         if(u(i).ge.u(i+1) .or. w(i).le.0.) go to 90
  50  continue
      if(iopt.ge.0) go to 70
      if(n.le.nmin .or. n.gt.nest) go to 90
      per = u(m)-u(1)
      j1 = k1
      t(j1) = u(1)
      i1 = n-k
      t(i1) = u(m)
      j2 = j1
      i2 = i1
      do 60 i=1,k
         i1 = i1+1
         i2 = i2-1
         j1 = j1+1
         j2 = j2-1
         t(j2) = t(i2)-per
         t(i1) = t(j1)+per
  60  continue
      call fpchep(u,m,t,n,k,ier)
      if(ier) 90,80,90
  70  if(s.lt.0.) go to 90
c   GH211012 Fix compare reals warning
      if(abs(s)<epsilon(s) .and. nest.lt.(m+2*k)) go to 90
      ier = 0
c we partition the working space and determine the spline approximation.
  80  ifp = 1
      iz = ifp+nest
      ia1 = iz+ncc
      ia2 = ia1+nest*k1
      ib = ia2+nest*k
      ig1 = ib+nest*k2
      ig2 = ig1+nest*k2
      iq = ig2+nest*k1
      call fpclos(iopt,idim,m,u,mx,x,w,k,s,nest,tol,maxit,k1,k2,n,t,
     * ncc,c,fp,wrk(ifp),wrk(iz),wrk(ia1),wrk(ia2),wrk(ib),wrk(ig1),
     * wrk(ig2),wrk(iq),iwrk,ier)
  90  return
      end