\ -----------------------------------------------------------------------------
\  Game of Life
\  Cellular Automata
\  Michel Jean 2019 update 2020
\ -----------------------------------------------------------------------------
S" pixel.f" Included

320 constant largeur-monde \
200 constant hauteur-monde
largeur-monde hauteur-monde * constant dim-monde

variable pos-X
variable pos-Y

0 pos-X !
0 pos-Y !

\ ===================================

create  monde dim-monde allot
create  monde-buf dim-monde allot

variable *monde
variable *monde-buf
variable tampon

variable total \ nbr voisins
variable etat

' monde *monde !
' monde-buf *monde-buf !

: centre ( n -- )
*monde @ + c@
;
\ 9 voisins possibles
: est ( n -- )
	1 + dim-monde mod *monde @ + c@ ;

: ouest ( n -- )
	1 - dim-monde mod *monde @ + c@ ;

: nord ( n -- )
	largeur-monde - dim-monde mod *monde @ + c@ ;

: sud ( n -- )
	largeur-monde + dim-monde mod *monde @ + c@ ;

: nord-est ( n -- )
	largeur-monde - 1 + dim-monde mod *monde @ + c@ ;

: nord-ouest ( n -- )
	largeur-monde - 1 - dim-monde mod *monde @ + c@ ;

: sud-est ( n -- )
	largeur-monde + 1 + dim-monde mod *monde @ + c@ ;

: sud-ouest ( n -- )
	largeur-monde + 1 - dim-monde mod *monde @ + c@ ;

\ voisinage de moore

: somme-moore ( n -- ) \ returne le nombre de voisins
	dup nord-ouest
	swap dup nord
	swap dup nord-est
	swap dup est
	swap dup sud-est
	swap dup sud
	swap dup sud-ouest
	swap ouest
	+ + + + + + +
;

\ regles de conway
: conway
	dup
	centre etat c!
	somme-moore total c!

	total @ 3 = if 1 etat c! else
	total @ 2 = if ( reste pareil ) else
	0 etat c!
	then then
	etat c@
;

\ =========================================

: initialisation ( -- ) \ monde aléatoire
	*monde @ dim-monde 0 fill
	dim-monde 0 do 10 random
	1 = if 1 *monde @ i + c! then loop
;

: regenere-monde
	dim-monde 0 do i conway *monde-buf @ i + c! loop
	*monde tampon 1 cells move
	*monde-buf *monde 1 cells move
	tampon *monde-buf 1 cells move
;

: dessine-monde ( -- )
	largeur-monde 0 do
	hauteur-monde 0 do
		largeur-monde i * j + *monde @ + c@ 1 = if
                j i green pixel else
		j i black pixel

	then
	loop loop
;

: run
	initialisation
        init-screen
	dessine-monde
	BEGIN
		dessine-monde
		regenere-monde
		view
		10 pause
        KEY?	UNTIL
        finish
;

: message
." Game of life " cr
." Type run to start" cr
." Press any key to stop" cr
;

message


*DECK DSOLBT
      SUBROUTINE DSOLBT (M, N, A, B, C, Y, IP)
      INTEGER M, N, IP(M,N)
      DOUBLE PRECISION A(M,M,N), B(M,M,N), C(M,M,N), Y(M,N)
C-----------------------------------------------------------------------
C Solution of block-tridiagonal linear system.
C Coefficient matrix must have been previously processed by DDECBT.
C M, N, A,B,C, and IP  must not have been changed since call to DDECBT.
C Written by A. C. Hindmarsh.
C Input:
C     M = order of each block.
C     N = number of blocks in each direction of matrix.
C A,B,C = M by M by N arrays containing block LU decomposition
C         of coefficient matrix from DDECBT.
C    IP = M by N integer array of pivot information from DDECBT.
C     Y = array of length M*N containg the right-hand side vector
C         (treated as an M by N array here).
C Output:
C     Y = solution vector, of length M*N.
C
C External routines required: DGESL (LINPACK) and DDOT (BLAS).
C-----------------------------------------------------------------------
C
      INTEGER NM1, NM2, I, K, KB, KM1, KP1
      DOUBLE PRECISION DP, DDOT
      NM1 = N - 1
      NM2 = N - 2
C Forward solution sweep. ----------------------------------------------
      CALL DGESL (A, M, M, IP, Y, 0)
      DO 30 K = 2,NM1
        KM1 = K - 1
        DO 20 I = 1,M
          DP = DDOT (M, C(I,1,K), M, Y(1,KM1), 1)
          Y(I,K) = Y(I,K) - DP
 20       CONTINUE
        CALL DGESL (A(1,1,K), M, M, IP(1,K), Y(1,K), 0)
 30     CONTINUE
      DO 50 I = 1,M
        DP = DDOT (M, C(I,1,N), M, Y(1,NM1), 1)
     1     + DDOT (M, B(I,1,N), M, Y(1,NM2), 1)
        Y(I,N) = Y(I,N) - DP
 50     CONTINUE
      CALL DGESL (A(1,1,N), M, M, IP(1,N), Y(1,N), 0)
C Backward solution sweep. ---------------------------------------------
      DO 80 KB = 1,NM1
        K = N - KB
        KP1 = K + 1
        DO 70 I = 1,M
          DP = DDOT (M, B(I,1,K), M, Y(1,KP1), 1)
          Y(I,K) = Y(I,K) - DP
 70       CONTINUE
 80     CONTINUE
      DO 100 I = 1,M
        DP = DDOT (M, C(I,1,1), M, Y(1,3), 1)
        Y(I,1) = Y(I,1) - DP
 100    CONTINUE
      RETURN
C----------------------- End of Subroutine DSOLBT ----------------------
      END


      SUBROUTINE QMSTEP (N,NPT,M,AMAT,B,XPT,XOPT,NACT,IACT,
     1  RESCON,QFAC,KOPT,KNEW,DEL,STEP,GL,PQW,RSTAT,W,IFEAS)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION AMAT(N,*),B(*),XPT(NPT,*),XOPT(*),IACT(*),
     1  RESCON(*),QFAC(N,*),STEP(*),GL(*),PQW(*),RSTAT(*),W(*)
C
C     N, NPT, M, AMAT, B, XPT, XOPT, NACT, IACT, RESCON, QFAC, KOPT are the
C       same as the terms with these names in SUBROUTINE LINCOB.
C     KNEW is the index of the interpolation point that is going to be moved.
C     DEL is the current restriction on the length of STEP, which is never
C       greater than the current trust region radius DELTA.
C     STEP will be set to the required step from XOPT to the new point.
C     GL must be set on entry to the gradient of LFUNC at XBASE, where LFUNC
C       is the KNEW-th Lagrange function. It is used also for some other
C       gradients of LFUNC.
C     PQW provides the second derivative parameters of LFUNC.
C     RSTAT and W are used for working space. Their lengths must be at least
C       M and N, respectively. RSTAT(J) is set to -1.0, 0.0, or 1.0 if the
C       J-th constraint is irrelevant, active, or both inactive and relevant,
C       respectively.
C     IFEAS will be set to 0 or 1 if XOPT+STEP is infeasible or feasible.
C
C     STEP is chosen to provide a relatively large value of the modulus of
C       LFUNC(XOPT+STEP), subject to ||STEP|| .LE. DEL. A projected STEP is
C       calculated too, within the trust region, that does not alter the
C       residuals of the active constraints. The projected step is preferred
C       if its value of | LFUNC(XOPT+STEP) | is at least one fifth of the
C       original one, but the greatest violation of a linear constraint must
C       be at least 0.2*DEL, in order to keep the interpolation points apart.
C       The remedy when the maximum constraint violation is too small is to
C       restore the original step, which is perturbed if necessary so that
C       its maximum constraint violation becomes 0.2*DEL.
C
C     Set some constants.
C
      HALF=0.5D0
      ONE=1.0D0
      TENTH=0.1D0
      ZERO=0.0D0
      TEST=0.2D0*DEL
C
C     Replace GL by the gradient of LFUNC at the trust region centre, and
C       set the elements of RSTAT.
C
      DO 20 K=1,NPT
      TEMP=ZERO
      DO 10 J=1,N
   10 TEMP=TEMP+XPT(K,J)*XOPT(J)
      TEMP=PQW(K)*TEMP
      DO 20 I=1,N
   20 GL(I)=GL(I)+TEMP*XPT(K,I)
      IF (M .GT. 0) THEN
          DO 30 J=1,M
          RSTAT(J)=ONE
   30     IF (DABS(RESCON(J)) .GE. DEL) RSTAT(J)=-ONE
          DO 40 K=1,NACT
   40     RSTAT(IACT(K))=ZERO
      END IF
C
C     Find the greatest modulus of LFUNC on a line through XOPT and
C       another interpolation point within the trust region.
C
      IFLAG=0
      VBIG=ZERO
      DO 60 K=1,NPT
      IF (K .EQ. KOPT) GOTO 60
      SS=ZERO
      SP=ZERO
      DO 50 I=1,N
      TEMP=XPT(K,I)-XOPT(I)
      SS=SS+TEMP*TEMP
   50 SP=SP+GL(I)*TEMP
      STP=-DEL/DSQRT(SS)
      IF (K .EQ. KNEW) THEN
          IF (SP*(SP-ONE) .LT. ZERO) STP=-STP
          VLAG=DABS(STP*SP)+STP*STP*DABS(SP-ONE)
      ELSE
          VLAG=DABS(STP*(ONE-STP)*SP)
      END IF
      IF (VLAG .GT. VBIG) THEN
          KSAV=K
          STPSAV=STP
          VBIG=VLAG
      END IF
   60 CONTINUE
C
C     Set STEP to the move that gives the greatest modulus calculated above.
C       This move may be replaced by a steepest ascent step from XOPT.
C
      GG=ZERO
      DO 70 I=1,N
      GG=GG+GL(I)**2
   70 STEP(I)=STPSAV*(XPT(KSAV,I)-XOPT(I))
      VGRAD=DEL*DSQRT(GG)
      IF (VGRAD .LE. TENTH*VBIG) GOTO 220
C
C     Make the replacement if it provides a larger value of VBIG.
C
      GHG=ZERO
      DO 90 K=1,NPT
      TEMP=ZERO
      DO 80 J=1,N
   80 TEMP=TEMP+XPT(K,J)*GL(J)
   90 GHG=GHG+PQW(K)*TEMP*TEMP
      VNEW=VGRAD+DABS(HALF*DEL*DEL*GHG/GG)
      IF (VNEW .GT. VBIG) THEN
          VBIG=VNEW
          STP=DEL/DSQRT(GG)
          IF (GHG .LT. ZERO) STP=-STP
          DO 100 I=1,N
  100     STEP(I)=STP*GL(I)
      END IF
      IF (NACT .EQ. 0 .OR. NACT .EQ. N) GOTO 220
C
C     Overwrite GL by its projection. Then set VNEW to the greatest
C       value of |LFUNC| on the projected gradient from XOPT subject to
C       the trust region bound. If VNEW is sufficiently large, then STEP
C       may be changed to a move along the projected gradient.
C
      DO 110 K=NACT+1,N
      W(K)=ZERO
      DO 110 I=1,N
  110 W(K)=W(K)+GL(I)*QFAC(I,K)
      GG=ZERO
      DO 130 I=1,N
      GL(I)=ZERO
      DO 120 K=NACT+1,N
  120 GL(I)=GL(I)+QFAC(I,K)*W(K)
  130 GG=GG+GL(I)**2
      VGRAD=DEL*DSQRT(GG)
      IF (VGRAD .LE. TENTH*VBIG) GOTO 220
      GHG=ZERO
      DO 150 K=1,NPT
      TEMP=ZERO
      DO 140 J=1,N
  140 TEMP=TEMP+XPT(K,J)*GL(J)
  150 GHG=GHG+PQW(K)*TEMP*TEMP
      VNEW=VGRAD+DABS(HALF*DEL*DEL*GHG/GG)
C
C     Set W to the possible move along the projected gradient.
C
      STP=DEL/DSQRT(GG)
      IF (GHG .LT. ZERO) STP=-STP
      WW=ZERO
      DO 160 I=1,N
      W(I)=STP*GL(I)
  160 WW=WW+W(I)**2
C
C     Set STEP to W if W gives a sufficiently large value of the modulus
C       of the Lagrange function, and if W either preserves feasibility
C       or gives a constraint violation of at least 0.2*DEL. The purpose
C       of CTOL below is to provide a check on feasibility that includes
C       a tolerance for contributions from computer rounding errors.
C
      IF (VNEW/VBIG .GE. 0.2D0) THEN
          IFEAS=1
          BIGV=ZERO
          J=0
  170     J=J+1
          IF (J .LE. M) THEN
              IF (RSTAT(J) .EQ. ONE) THEN
                  TEMP=-RESCON(J)
                  DO 180 I=1,N
  180             TEMP=TEMP+W(I)*AMAT(I,J)
                  BIGV=DMAX1(BIGV,TEMP)
              END IF
              IF (BIGV .LT. TEST) GOTO 170
              IFEAS=0
          END IF
          CTOL=ZERO
          TEMP=0.01D0*DSQRT(WW)
          IF (BIGV .GT. ZERO .AND. BIGV .LT. TEMP) THEN
              DO 200 K=1,NACT
              J=IACT(K)
              SUM=ZERO
              DO 190 I=1,N
  190         SUM=SUM+W(I)*AMAT(I,J)
  200         CTOL=DMAX1(CTOL,DABS(SUM))
          END IF
          IF (BIGV .LE. 10.0D0*CTOL .OR. BIGV .GE. TEST) THEN
              DO 210 I=1,N
  210         STEP(I)=W(I)
              GOTO 260
          END IF
      END IF
C
C     Calculate the greatest constraint violation at XOPT+STEP with STEP at
C       its original value. Modify STEP if this violation is unacceptable.
C
  220 IFEAS=1
      BIGV=ZERO
      RESMAX=ZERO
      J=0
  230 J=J+1
      IF (J .LE. M) THEN
          IF (RSTAT(J) .LT. ZERO) GOTO 230
          TEMP=-RESCON(J)
          DO 240 I=1,N
  240     TEMP=TEMP+STEP(I)*AMAT(I,J)
          RESMAX=DMAX1(RESMAX,TEMP)
          IF (TEMP .LT. TEST) THEN
              IF (TEMP .LE. BIGV) GOTO 230
              BIGV=TEMP
              JSAV=J
              IFEAS=-1
              GOTO 230
          END IF
          IFEAS=0
      END IF
      IF (IFEAS .EQ. -1) THEN
          DO 250 I=1,N
  250     STEP(I)=STEP(I)+(TEST-BIGV)*AMAT(I,JSAV)
          IFEAS=0
      END IF
C
C     Return the calculated STEP and the value of IFEAS.
C
  260 RETURN
      END


      subroutine dipow(n,v,iv,ipow,ierr)
c!but
c     eleve a une puissance entiere les elements d'un vecteur de flottants
c     double precision
c!liste d'appel
c     subroutine dipow(n,v,iv,ipow,ierr)
c     integer n,iv,ipow ,ierr
c     double precision v(n*iv)
c
c     n : nombre d'element du vecteur
c     v : tableau contenant les elements du vecteur
c     iv : increment entre deux element consecutif du vecteur dans le
c          tableau v
c     ipow : puissance a la quelle doivent etre eleves les elements du
c            vecteur
c     ierr : indicateur d'erreur
c            ierr=0 si ok
c            ierr=1 si 0**0
c            ierr=2 si 0**k avec k<0
c!origine
c Serge Steer INRIA 1989
c!
c     Copyright INRIA
      integer n,iv,ipow ,ierr
      double precision v(*)
c
      ierr=0
c
      if(ipow.eq.1) return
      if(ipow.eq.0) then
c     puissance 0
         ii=1
         do 10 i=1,n
            if(v(ii).ne.0.0d+0) then
               v(ii)=1.0d+0
               ii=ii+iv
            else
               ierr=1
               return
            endif
 10      continue
      else if(ipow.lt.0) then
c     puissance negative
         ii=1
         do 20 i=1,n
            if(v(ii).ne.0.0d+0) then
               v(ii)=v(ii)**ipow
               ii=ii+iv
            else
               ierr=2
               return
            endif
 20      continue
      else
c     puissance  positive
         ii=1
         do 30 i=1,n
            v(ii)=v(ii)**ipow
            ii=ii+iv
 30      continue
      endif
c
      return
      end


!##############################################################################
!# ****************************************************************************
!# <name> gridsmooth </name>
!# ****************************************************************************
!#
!# <purpose>
!# The following routines can be found here:
!#
!# 1.) gsmth_laplaceHC2d
!#     -> HC version of the laplace smoother
!# 2.) gsmth_laplace2d
!#     -> a relaxation parameter is added to soften the
!#        smoothing.
!# 3.) gsmth_umbrella2d
!#     -> implements a basic umbrella smoother
!# 4.) gsmth_laplace
!#     -> wrapper for the laplace smoother
!# 4.) gsmth_laplace
!#     -> wrapper for the laplace smoother
!# 5.) gsmth_umbrella
!#     -> wrapper for the umbrella smoother
!# </purpose>
!##############################################################################

module gridsmooth

  use triangulation
  use fsystem
  use basicgeometry
  use storage

  implicit none

contains

!<subroutine>
  subroutine gsmth_laplaceHC2d(rtriangulation)

!<description>
  !
  ! Implements a laplace smoother that uses a relaxation parameter:
  ! p_new = p + (drelax/n) * sum_{i=0}^{n-1} (q_i - p),
  ! where p: position of vertex, n: #neighbours of p, q_i: adjacent vertices
  ! of p.
  !
!</description>

!<inputoutput>
  ! triangulation.
  type(t_triangulation), intent(INOUT) :: rtriangulation
!</inputoutput>

!</subroutine>

  ! local variables
  integer, dimension(:,:), pointer :: p_IverticesAtEdge
  real(DP), dimension(:,:), pointer :: p_DvertexCoords
  integer :: iedge,ibct,isize,NMT,ivt1,ivt2,ive
  integer, dimension(:), allocatable :: Icount
  real, dimension(:,:), allocatable :: Dcoords
  integer, dimension(:), pointer   :: p_Iproperty
  real :: dx1,dx2,dy1,dy2,dn,drel1
  real :: drelax

  drelax = 0.5_dp

  call storage_getbase_int2D (rtriangulation%h_IverticesAtEdge,&
      p_IverticesAtEdge)

  call storage_getbase_double2D (rtriangulation%h_DvertexCoords,&
      p_DvertexCoords)

  call storage_getbase_int(&
      rtriangulation%h_InodalProperty,p_Iproperty)

  allocate(Icount(rtriangulation%NVT))

  allocate(Dcoords(2,rtriangulation%NVT))

  Icount = 0
  Dcoords = 0.0_dp

  ! loop over all edges
  do iedge=1,rtriangulation%NMT

    ! get the adjacent vertices
    ivt1 = p_IverticesAtEdge(1,iedge)
    ivt2 = p_IverticesAtEdge(2,iedge)

    ! get the coordinates
    dx1 = p_DvertexCoords(1,ivt1)
    dy1 = p_DvertexCoords(2,ivt1)

    dx2 = p_DvertexCoords(1,ivt2)
    dy2 = p_DvertexCoords(2,ivt2)

    if(p_Iproperty(ivt1) .eq. 0)then
      Dcoords(1,ivt1) = Dcoords(1,ivt1) + &
                        (p_DvertexCoords(1,ivt2) - p_DvertexCoords(1,ivt1))
      Dcoords(2,ivt1) = Dcoords(2,ivt1) + &
                        (p_DvertexCoords(2,ivt2) - p_DvertexCoords(2,ivt1))
      Icount(ivt1) = Icount(ivt1) + 1
    end if

    if(p_Iproperty(ivt2) .eq. 0)then
      Dcoords(1,ivt2) = Dcoords(1,ivt2) + &
                        (p_DvertexCoords(1,ivt1) - p_DvertexCoords(1,ivt2))
      Dcoords(2,ivt2) = Dcoords(2,ivt2) + &
                        (p_DvertexCoords(2,ivt1) - p_DvertexCoords(2,ivt2))
      Icount(ivt2) = Icount(ivt2) + 1
    end if

  end do ! end iedge

  ! loop over the vertices and correct
  do ive=1,rtriangulation%NVT
    if(p_Iproperty(ive) .ne. 0)cycle
    dn = real(Icount(ive))
    Dcoords(1,ive) = Dcoords(1,ive) * drelax/dn
    Dcoords(2,ive) = Dcoords(2,ive) * drelax/dn
  end do

  ! loop and copy
  do ive=1,rtriangulation%NVT
    if(p_Iproperty(ive) .ne. 0)cycle
    p_DvertexCoords(1,ive) = p_DvertexCoords(1,ive) + Dcoords(1,ive)
    p_DvertexCoords(2,ive) = p_DvertexCoords(2,ive) + Dcoords(2,ive)
  end do

  end subroutine

 ! ****************************************************************************************

!<subroutine>
  subroutine gsmth_laplace2d(rtriangulation)

!<description>
  !
  ! Implements a laplace smoother that uses a relaxation parameter:
  ! p_new = p + (drelax/n) * sum_{i=0}^{n-1} (q_i - p),
  ! where p: position of vertex, n: #neighbours of p, q_i: adjacent vertices
  ! of p.
  !
!</description>

!<inputoutput>
  ! triangulation.
  type(t_triangulation), intent(INOUT) :: rtriangulation
!</inputoutput>

!</subroutine>

  ! local variables
  integer(PREC_VERTEXIDX), dimension(:,:), pointer :: p_IverticesAtEdge
  real(DP), dimension(:,:), pointer :: p_DvertexCoords
  integer :: iedge,ibct,isize,NMT,ivt1,ivt2,ive
  integer, dimension(:), allocatable :: Icount
  real, dimension(:,:), allocatable :: Dcoords
  integer, dimension(:), pointer   :: p_Iproperty
  real :: dx1,dx2,dy1,dy2,dn,drel1
  real :: drelax

  drelax = 0.5_dp

  call storage_getbase_int2D (rtriangulation%h_IverticesAtEdge,&
      p_IverticesAtEdge)

  call storage_getbase_double2D (rtriangulation%h_DvertexCoords,&
      p_DvertexCoords)

  call storage_getbase_int(&
      rtriangulation%h_InodalProperty,p_Iproperty)

  allocate(Icount(rtriangulation%NVT))

  allocate(Dcoords(2,rtriangulation%NVT))

  Icount = 0
  Dcoords = 0.0_dp

  ! loop over all edges
  do iedge=1,rtriangulation%NMT

    ! get the adjacent vertices
    ivt1 = p_IverticesAtEdge(1,iedge)
    ivt2 = p_IverticesAtEdge(2,iedge)

    ! get the coordinates
    dx1 = p_DvertexCoords(1,ivt1)
    dy1 = p_DvertexCoords(2,ivt1)

    dx2 = p_DvertexCoords(1,ivt2)
    dy2 = p_DvertexCoords(2,ivt2)

    if(p_Iproperty(ivt1) .eq. 0)then
      Dcoords(1,ivt1) = Dcoords(1,ivt1) + &
                        (p_DvertexCoords(1,ivt2) - p_DvertexCoords(1,ivt1))
      Dcoords(2,ivt1) = Dcoords(2,ivt1) + &
                        (p_DvertexCoords(2,ivt2) - p_DvertexCoords(2,ivt1))
      Icount(ivt1) = Icount(ivt1) + 1
    end if

    if(p_Iproperty(ivt2) .eq. 0)then
      Dcoords(1,ivt2) = Dcoords(1,ivt2) + &
                        (p_DvertexCoords(1,ivt1) - p_DvertexCoords(1,ivt2))
      Dcoords(2,ivt2) = Dcoords(2,ivt2) + &
                        (p_DvertexCoords(2,ivt1) - p_DvertexCoords(2,ivt2))
      Icount(ivt2) = Icount(ivt2) + 1
    end if

  end do ! end iedge

  ! loop over the vertices and correct
  do ive=1,rtriangulation%NVT
    if(p_Iproperty(ive) .ne. 0)cycle
    dn = real(Icount(ive))
    Dcoords(1,ive) = Dcoords(1,ive) * drelax/dn
    Dcoords(2,ive) = Dcoords(2,ive) * drelax/dn
  end do

  ! loop and copy
  do ive=1,rtriangulation%NVT
    if(p_Iproperty(ive) .ne. 0)cycle
    p_DvertexCoords(1,ive) = p_DvertexCoords(1,ive) + Dcoords(1,ive)
    p_DvertexCoords(2,ive) = p_DvertexCoords(2,ive) + Dcoords(2,ive)
  end do

  end subroutine

 ! ****************************************************************************************

!<subroutine>
  subroutine gsmth_umbrella2d(rtriangulation)

!<description>
  !
  ! Implements a laplace smoother that uses a relaxation parameter:
  ! p_new = (1-relax) * p + (drelax/sum_{i=0}^{n-1} d_i) * sum_{i=0}^{n-1} d_i*q_i ,
  ! where p: position of vertex, n: #neighbours of p, q_i: adjacent vertices
  ! of p, d_i: length of edge(p,d_i)
  !
!</description>

!<inputoutput>
  ! triangulation.
  type(t_triangulation), intent(INOUT) :: rtriangulation
!</inputoutput>

!</subroutine>

  ! local variables
  integer(PREC_VERTEXIDX), dimension(:,:), pointer :: p_IverticesAtEdge
  real(DP), dimension(:,:), pointer :: p_DvertexCoords
  integer :: iedge,ibct,isize,NMT,ivt1,ivt2,ive
  integer, dimension(:), allocatable :: Icount
  real, dimension(:,:), allocatable :: Dcoords
  real, dimension(:), allocatable :: Dweight
  integer, dimension(:), pointer   :: p_Iproperty
  real :: dx1,dx2,dy1,dy2,dn,dw
  real :: drelax

  drelax = 0.5_dp

  call storage_getbase_int2D (rtriangulation%h_IverticesAtEdge,&
      p_IverticesAtEdge)

  call storage_getbase_double2D (rtriangulation%h_DvertexCoords,&
      p_DvertexCoords)

  call storage_getbase_int(&
      rtriangulation%h_InodalProperty,p_Iproperty)

  allocate(Icount(rtriangulation%NVT))

  allocate(Dcoords(2,rtriangulation%NVT))

  allocate(Dweight(rtriangulation%NVT))

  Icount = 0
  Dcoords = 0.0_dp
  Dweight = 0.0_dp

  ! loop over all edges
  do iedge=1,rtriangulation%NMT

    ! get the adjacent vertices
    ivt1 = p_IverticesAtEdge(1,iedge)
    ivt2 = p_IverticesAtEdge(2,iedge)

    ! get the coordinates
    dx1 = p_DvertexCoords(1,ivt1)
    dy1 = p_DvertexCoords(2,ivt1)

    dx2 = p_DvertexCoords(1,ivt2)
    dy2 = p_DvertexCoords(2,ivt2)

    dw = sqrt((p_DvertexCoords(1,ivt1)-p_DvertexCoords(1,ivt2))**2 + &
              (p_DvertexCoords(2,ivt1)-p_DvertexCoords(2,ivt2))**2)

    if(p_Iproperty(ivt1) .eq. 0)then
      ! add the edge weighted by its length
      Dcoords(1,ivt1) = Dcoords(1,ivt1) + dw * p_DvertexCoords(1,ivt2)
      Dcoords(2,ivt1) = Dcoords(2,ivt1) + dw * p_DvertexCoords(2,ivt2)
      Icount(ivt1) = Icount(ivt1) + 1
      Dweight(ivt1) = Dweight(ivt1) + dw
    end if

    if(p_Iproperty(ivt2) .eq. 0)then
      ! add the edge weighted by its length
      Dcoords(1,ivt2) = Dcoords(1,ivt2) + dw * p_DvertexCoords(1,ivt1)
      Dcoords(2,ivt2) = Dcoords(2,ivt2) + dw * p_DvertexCoords(2,ivt1)
      Icount(ivt2) = Icount(ivt2) + 1
      Dweight(ivt2) = Dweight(ivt2) + dw
    end if

  end do ! end iedge

  ! loop over the vertices and correct
  do ive=1,rtriangulation%NVT
    if(p_Iproperty(ive) .ne. 0)cycle
    dn = real(Icount(ive))
    Dcoords(1,ive) = Dcoords(1,ive) * drelax/Dweight(ive)
    Dcoords(2,ive) = Dcoords(2,ive) * drelax/Dweight(ive)
  end do

  dw = 1.0_dp - drelax
  ! loop and copy
  do ive=1,rtriangulation%NVT
    if(p_Iproperty(ive) .ne. 0)cycle
    p_DvertexCoords(1,ive) = dw * p_DvertexCoords(1,ive) + Dcoords(1,ive)
    p_DvertexCoords(2,ive) = dw * p_DvertexCoords(2,ive) + Dcoords(2,ive)
  end do

  end subroutine

 ! ****************************************************************************************

!<subroutine>
  subroutine gsmth_laplace(rtriangulation)

!<description>
  !
  ! This wrapper examines the dimension of
  ! the problem and calls the according subroutine
  !
!</description>

!<inputoutput>
  ! triangulation.
  type(t_triangulation), intent(INOUT) :: rtriangulation
!</inputoutput>

!</subroutine>

  if(rtriangulation%ndim .eq. NDIM2D) then
    call gsmth_laplace2d(rtriangulation)
  else if(rtriangulation%ndim .eq. NDIM3D) then

  end if

  end subroutine

 ! ****************************************************************************************

!<subroutine>
  subroutine gsmth_umbrella(rtriangulation)

!<description>
  !
  ! This wrapper examines the dimension of
  ! the problem and calls the according subroutine
  !
!</description>

!<inputoutput>
  ! triangulation.
  type(t_triangulation), intent(INOUT) :: rtriangulation
!</inputoutput>

!</subroutine>

  if(rtriangulation%ndim .eq. NDIM2D) then
    call gsmth_umbrella2d(rtriangulation)
  else if(rtriangulation%ndim .eq. NDIM3D) then

  end if

  end subroutine

end module


!*robodoc*m* CGPACK/cgca_m2rot
!  NAME
!    cgca_m2rot
!  SYNOPSIS

!$Id: cgca_m2rot.f90 526 2018-03-25 23:44:51Z mexas $

module cgca_m2rot

!  DESCRIPTION
!    Module dealing with tensor rotations, orientations,
!    mis-orientations
!  AUTHOR
!    Anton Shterenlikht
!  COPYRIGHT
!    See LICENSE
!  CONTAINS
!    cgca_rt, cgca_ckrt, rtprint, cgca_csym, cgca_csym_pure,
!    cgca_mis, cgca_miscsym
!  USES
!    cgca_m1co
!  USED BY
!    cgca
!  SOURCE

use cgca_m1co, only : idef, ldef, rdef, cgca_pi
implicit none

private
public :: cgca_ckrt, cgca_csym, cgca_csym_pure, cgca_mis, &
  cgca_miscsym, cgca_rt

contains

!*roboend*

!*robodoc*s* cgca_m2rot/cgca_rt
!  NAME
!    cgca_rt
!  SYNOPSIS

subroutine cgca_rt(r)

!  INPUT
!    Array r to store output
!  OUTPUT

real(kind=rdef),allocatable,intent(inout) :: r(:,:,:)[:,:,:]

!  DESCRIPTION
!    Choose grain rotation tensors at random and return in a
!    coarray r(:,:,:)[:,:,:]. dimension 1 of the coarray is the grain
!    number. dimensions 2 and 3 are for the rotation tensor for the
!    grain, e.g. r(387,2,1) is the rotation tensor component r21 for
!    grain 387.
!
!    Image 1 assigns rotation tensors to all grains. then all other
!    images copy the coarray from image 1.
!
!    The method: choose 3 random angles. Then interpret them as
!    rotations about axes 1, 2 and 3 in turn. The resulting rotation
!    will be quite random.
!
!    Grain axes are the crystallographic directions:
!
!      axis  direction
!        1     [100]
!        2     [010]
!        3     [001]
!
!    Then the grain orientation tensor for some grain z is defined as:
!
!      r(z,1,1) r(z,1,2) r(z,1,3)
!      r(z,2,1) r(z,2,2) r(z,2,3)
!      r(z,3,1) r(z,3,2) r(z,3,3)
!
!    Index 2  is the grain axis, index 3 is the space axis, i.e.
!    r(z,i,j)= cos(x_i_grain,x_j_space), e.g.
!    r(z,3,2) = cos(3_grain,2_space) is the angle between grain
!    axis 3 and the space axix 2 for grain z.
!
!    This leads to the important convention:
!
!      x_grain =           r  * x_space
!      x_space = transpose(r) * x_grain
!
!    *All* other routines must adhere to this convention.
!  NOTES
!    Call cgca_art before calling this routine.
!  USES
!    none
!  USED BY
!    none, end user
!  SOURCE

real( kind=rdef ), parameter :: zero = 0.0_rdef, one = 1.0_rdef,       &
  eight=8.0_rdef, twopi = 2 * cgca_pi
real(kind=rdef) :: a(3),q(3,3)
real :: rndnum(3)

integer(kind=idef) :: l(3),u(3),lcob(3),ucob(3),i

! check for allocated
if (.not. allocated(r)) error stop "error in cgca_rt: r is not allocated"

! define cobounds on all images. these are used at the end
! to read the values from image 1.
lcob=lcobound(r)
ucob=ucobound(r)

! Image 1 does all work, otherwise lots of syncs will be needed
image1: if (this_image() .eq. 1) then

! coarray bounds
l=lbound(r)
u=ubound(r)

! check that bounds for dimensions 2 and 3 are 1:3
if (l(2) .ne. 1 .or. l(3) .ne. 1 .or. &
    u(2) .ne. 3 .or. u(3) .ne. 3) then
  write (*,'(a)') &
    "error in cgca_rt: coarray bounds along dimensions 2 or 3 are wrong."
  write (*,'(a)') &
    "error in cgca_rt: these must be [1:3]."
  error stop
end if

! loop over all grains
main: do i=l(1),u(1)

call random_number(rndnum)         ! in [0,1)
a=real(rndnum,kind=rdef)*twopi     ! a in [0,2*pi)

! rotation about 1
 r(i,:,:)=zero
 r(i,1,1)=one
 r(i,2,2)=cos(a(1))
 r(i,2,3)=sin(a(1))
 r(i,3,2)=-r(i,2,3)
 r(i,3,3)=r(i,2,2)

! rotation about 2
 q=zero
 q(1,1)=cos(a(2))
 q(1,3)=sin(a(2))
 q(2,2)=one
 q(3,1)=-q(1,3)
 q(3,3)=q(1,1)

! intermediate compound rotation
 r(i,:,:) = matmul(q,r(i,:,:))

! rotation about 3
 q=zero
 q(1,1)=cos(a(3))
 q(1,2)=sin(a(3))
 q(2,1)=-q(1,2)
 q(2,2)=q(1,1)
 q(3,3)=one

! final compound rotation
 r(i,:,:) = matmul(q,r(i,:,:))

end do main

end if image1

! global sync here
sync all

! all images read r from image 1
r(:,:,:) = r(:,:,:)[lcob(1),lcob(2),lcob(3)]

! exit only after all images have the rotation tensors assigned.
sync all

end subroutine cgca_rt

!*roboend*

!*robodoc*s* cgca_m2rot/cgca_ckrt
!  NAME
!    cgca_ckrt
!  SYNOPSIS

subroutine cgca_ckrt(r,debug,flag)

!  INPUTS

real(kind=rdef),intent(in) :: r(3,3)
logical(kind=ldef),intent(in) :: debug

!  OUTPUT

integer(kind=idef),intent(out) :: flag

!  DESCRIPTION
!    Check that the given rotation tensor r(3,3) is
!    orthogonal.
!    If debug .eq. .true., then  verbose diagnostics is
!    printed on error.
!    In this case a non-zero return flag shows the number
!    of the failed test.
!  USES
!    rtprint
!  USED BY
!    none, end user
!  SOURCE

real(kind=rdef),parameter :: one=1.0_rdef,factor=1.0e1_rdef
integer :: i
real :: maxerr, orthogon(3,3), tmp(3,3)

maxerr = factor * epsilon(one)

flag = 0
tmp = transpose(r)
 do i=1,2
   if ( i .eq. 1 ) orthogon = matmul( r, tmp )
   if ( i .eq. 2 ) orthogon = matmul( tmp, r )

   if (abs(orthogon(1,1)-one) .gt. maxerr) then
     if (debug) call rtprint( r, tmp, orthogon, maxerr )
     flag = 1 * i
     return
   end if

   if (abs(orthogon(1,2))     .gt. maxerr) then
     if (debug) call rtprint( r, tmp, orthogon, maxerr )
     flag = 2 * i
     return
   end if

   if (abs(orthogon(1,3))     .gt. maxerr) then
     if (debug) call rtprint( r, tmp, orthogon, maxerr )
     flag = 3 * i
     return
   end if

   if (abs(orthogon(2,1))     .gt. maxerr) then
     if (debug) call rtprint( r, tmp, orthogon, maxerr )
     flag = 4 * i
     return
   end if

   if (abs(orthogon(2,2)-one) .gt. maxerr) then
     if (debug) call rtprint( r, tmp, orthogon, maxerr )
     flag = 5 * i
     return
   end if

   if (abs(orthogon(2,3))     .gt. maxerr) then
     if (debug) call rtprint( r, tmp, orthogon, maxerr )
     flag = 6 * i
     return
   end if

   if (abs(orthogon(3,1))     .gt. maxerr) then
     if (debug) call rtprint( r, tmp, orthogon, maxerr )
     flag = 7 * i
     return
   end if

   if (abs(orthogon(3,2))     .gt. maxerr) then
     if (debug) call rtprint( r, tmp, orthogon, maxerr )
     flag = 8 * i
     return
   end if

   if (abs(orthogon(3,3)-one) .gt. maxerr) then
     if (debug) call rtprint( r, tmp, orthogon, maxerr )
     flag = 9 * i
     return
   end if

 end do

end subroutine cgca_ckrt

!*roboend*

!*robodoc*s* cgca_m2rot/rtprint
!  NAME
!    rtprint
!  SYNOPSIS

subroutine rtprint(a,b,c,err)

!  INPUT

real(kind=rdef),intent(in) :: a(3,3),b(3,3),c(3,3),err

!  SIDE EFFECTS
!    dumps some text on stdout
!  DESCRIPTION
!    This routine prints on stdout the details of the
!    rotation tensor that failed one of the tests.
!    It prints the tensor itself, as a matrix, the
!    transposed tensor, and then a product.
!  NOTES
!    This routine is not accessible from outside of
!    module cgca_m2rot.
!  USES
!    none
!  USED BY
!    cgca_ckrt
!  SOURCE

integer :: i

write (*,'(a)') "troublesome tensor:"
do i=1,3
  write (*,*) a(i,:)
end do

write (*,*)

write (*,'(a)') "transposed troublesome tensor:"
do i=1,3
  write (*,*) b(i,:)
end do

write (*,*)
write (*,'(a)') "this should have been the unit tensor:"
do i=1,3
  write (*,*) c(i,:)
end do

write (*,*)"max allowed error was:", err

end subroutine rtprint

!*roboend*

!*robodoc*s* cgca_m2rot/cgca_csym
!  NAME
!    cgca_csym
!  SYNOPSIS

subroutine cgca_csym( num, rs )

!  INPUT

integer, intent( in ) :: num

!  OUTPUT

real( kind=rdef ), intent( out ) :: rs(3,3)

!  NOTES
!    The symmetry tensors and the misorientation angle
!    equations can be found in "Introduction to texture
!    analysis : macrotexture, microtexture, and
!    orientation mapping", Olaf Engler, Valerie Randle,
!    2nd ed, Boca Raton, CRC Press, 2010, 456 p.
!
!    There is a copy in QBL.
!  DESCRIPTION
!    This routine stores, and outputs on demand, symmetry rotation
!    tensors, for cubic crystals, 24 in total.
!    The first tensor is the unit tensor (trivial case).
!    Then there are 23 non-trivial tensors.
!    There are 24*3*3=216 elements in total:
!    - num - rotation symmetry tensor number
!    - rs - rotation symmetry tensor
!  USES
!    none
!  USED BY
!    cgca_miscsym
!  SOURCE

real( kind=rdef ), parameter :: mnsone = -1.0_rdef,      &
                                  zero =  0.0_rdef,      &
                                   one =  1.0_rdef

! Keep the identity tensor as well, at number zero, if required in future.
! Data are filled columns first!

real( kind=rdef ), parameter :: r(3,3,24) = reshape(     &
(/ one,zero,zero,    zero,one,zero,    zero,zero,one,    &
   one,zero,zero,    zero,zero,mnsone, zero,one,zero,    &
   one,zero,zero,    zero,mnsone,zero, zero,zero,mnsone, &

   one,zero,zero,    zero,zero,one,    zero,mnsone,zero, &
   zero,zero,one,    zero,one,zero,    mnsone,zero,zero, &
   mnsone,zero,zero, zero,one,zero,    zero,zero,mnsone, &

   zero,zero,mnsone, zero,one,zero,    one,zero,zero,    &
   zero,mnsone,zero, one,zero,zero,    zero,zero,one,    &
   mnsone,zero,zero, zero,mnsone,zero, zero,zero,one,    &
   zero,one,zero,    mnsone,zero,zero, zero,zero,one,    &

   zero,zero,one,    one,zero,zero,    zero,one,zero,    &
   mnsone,zero,zero, zero,zero,one,    zero,one,zero,    &
   zero,zero,mnsone, mnsone,zero,zero, zero,one,zero,    &

   zero,mnsone,zero, zero,zero,mnsone, one,zero,zero,    &
   mnsone,zero,zero, zero,zero,mnsone, zero,mnsone,zero, &
   zero,one,zero,    zero,zero,mnsone, mnsone,zero,zero, &

   zero,zero,one,    zero,mnsone,zero, one,zero,zero,    &
   zero,zero,mnsone, zero,mnsone,zero, mnsone,zero,zero, &
   zero,one,zero,    one,zero,zero,    zero,zero,mnsone, &
   zero,mnsone,zero, mnsone,zero,zero, zero,zero,mnsone, &

   zero,zero,one,    mnsone,zero,zero, zero,mnsone,zero, &
   zero,zero,mnsone, one,zero,zero,    zero,mnsone,zero, &
   zero,mnsone,zero, zero,zero,one,    mnsone,zero,zero, &
   zero,one,zero,    zero,zero,one,    one,zero,zero /), &
   (/3,3,24/) )

! sanity check

if (num .lt. 1 .or. num .gt. 24) then
  write (*,'(a,i0)') "ERROR: cgca_csym: image: ", this_image()
  write (*,'(a)') "ERROR: cgca_csym: num is out of range [1..24]"
  error stop
end if

! simply return the required rotation tensor

rs = r(:,:,num)

end subroutine cgca_csym

!*roboend*

!*robodoc*s* cgca_m2rot/cgca_csym_pure
!  NAME
!    cgca_csym_pure
!  SYNOPSIS

pure subroutine cgca_csym_pure( num, rs, flag )

!  INPUT
!    - num - rotation symmetry tensor number

integer( kind=idef ), intent(in) :: num

!  OUTPUT
!    - rs - rotation symmetry tensor

real( kind=rdef ), intent(out) :: rs(3,3)
integer, intent(out) :: flag

!  NOTES
!    This is a PURE subroutine. Hence no external IO is required.
!    Hence I'll report back the errors via a flag:
!      0 - sucessful completion.
!      1 - number is out of range [1..24].
!  DESCRIPTION
!    This routine stores, and outputs on demand, symmetry rotation
!    tensors, for cubic crystals, 24 in total.
!    The first tensor is the unit tensor (trivial case).
!    Then there are 23 non-trivial tensors.
!    There are 24*3*3=216 elements in total.

!    The symmetry tensors and the misorientation angle
!    equations can be found in "Introduction to texture
!    analysis : macrotexture, microtexture, and
!    orientation mapping", Olaf Engler, Valerie Randle,
!    2nd ed, Boca Raton, CRC Press, 2010, 456 p.
!  USES
!    none
!  USED BY
!    cgca_miscsym
!  SOURCE

real( kind=rdef ), parameter :: mnsone = -1.0_rdef,      &
                                  zero =  0.0_rdef,      &
                                   one =  1.0_rdef

! Keep the identity tensor as well, at number zero,
! if required in future. Data are filled columns first!

real( kind=rdef ), parameter :: r(3,3,24) = reshape(     &
(/ one,zero,zero,    zero,one,zero,    zero,zero,one,    &
   one,zero,zero,    zero,zero,mnsone, zero,one,zero,    &
   one,zero,zero,    zero,mnsone,zero, zero,zero,mnsone, &

   one,zero,zero,    zero,zero,one,    zero,mnsone,zero, &
   zero,zero,one,    zero,one,zero,    mnsone,zero,zero, &
   mnsone,zero,zero, zero,one,zero,    zero,zero,mnsone, &

   zero,zero,mnsone, zero,one,zero,    one,zero,zero,    &
   zero,mnsone,zero, one,zero,zero,    zero,zero,one,    &
   mnsone,zero,zero, zero,mnsone,zero, zero,zero,one,    &
   zero,one,zero,    mnsone,zero,zero, zero,zero,one,    &

   zero,zero,one,    one,zero,zero,    zero,one,zero,    &
   mnsone,zero,zero, zero,zero,one,    zero,one,zero,    &
   zero,zero,mnsone, mnsone,zero,zero, zero,one,zero,    &

   zero,mnsone,zero, zero,zero,mnsone, one,zero,zero,    &
   mnsone,zero,zero, zero,zero,mnsone, zero,mnsone,zero, &
   zero,one,zero,    zero,zero,mnsone, mnsone,zero,zero, &

   zero,zero,one,    zero,mnsone,zero, one,zero,zero,    &
   zero,zero,mnsone, zero,mnsone,zero, mnsone,zero,zero, &
   zero,one,zero,    one,zero,zero,    zero,zero,mnsone, &
   zero,mnsone,zero, mnsone,zero,zero, zero,zero,mnsone, &

   zero,zero,one,    mnsone,zero,zero, zero,mnsone,zero, &
   zero,zero,mnsone, one,zero,zero,    zero,mnsone,zero, &
   zero,mnsone,zero, zero,zero,one,    mnsone,zero,zero, &
   zero,one,zero,    zero,zero,one,    one,zero,zero /), &
   (/3,3,24/) )

! Set to zero initially
rs = zero

! sanity check
if (num .lt. 1 .or. num .gt. 24) then
  flag = 1
  return
end if

! If there are no error conditions, simply return the
! required rotation tensor and set the flag to 0.

flag = 0
  rs = r( :, :, num )

end subroutine cgca_csym_pure

!*roboend*

!*robodoc*s* cgca_m2rot/cgca_mis
!  NAME
!    cgca_mis
!  SYNOPSIS

subroutine cgca_mis(r1,r2,angle)

!  INPUTS

!real(kind=rdef),intent(in) :: r1(3,3),r2(3,3)
real(kind=rdef),intent(in) :: r1(:,:),r2(:,:)
!  OUTPUT

real(kind=rdef),intent(out) :: angle

!  DESCRIPTION
!    This routine calculates grain misoreintation.
!    Given 2 orientation tensors, r1 and r2, the
!    misorientation angle (in rad) is:
!    acos((tr(r1*r2^t)-1)/2), where "tr" is tensor trace.
!    The angle is [0,pi].
!  USES
!    none
!  USED BY
!    cgca_miscsym
!  SOURCE

real(kind=rdef),parameter :: one=1.0_rdef
real(kind=rdef) :: misor(3,3),trace,arg

misor=matmul(r1,transpose(r2))
trace=misor(1,1)+misor(2,2)+misor(3,3)
arg = (trace-one) / 2

if (arg .gt.  one) arg= one
if (arg .lt. -one) arg=-one

angle = acos(arg)

if (isnan(angle)) then
  write (*,'(a,i0)') "ERROR: cgca_mis: image: ", this_image()
  write (*,'(a,i0)') "ERROR: cgca_mis: arg: ", arg
  write (*,'(a,i0)') "ERROR: cgca_mis: angle=acos(arg) is NAN"
  error stop
end if

end subroutine cgca_mis

!*roboend*

!*robodoc*s* cgca_m2rot/cgca_miscsym
!  NAME
!    cgca_miscsym
!  SYNOPSIS

subroutine cgca_miscsym(r1,r2,minang)

!  INPUTS

!real(kind=rdef),intent(in) :: r1(3,3),r2(3,3)
real(kind=rdef),intent(in) :: r1(:,:),r2(:,:)
!  OUTPUT

real(kind=rdef),intent(out) :: minang

!  USES
!    cgca_csym, cgca_mis
!  USED BY
!  DESCRIPTION
!    This routine calculates the grain misorientation. angle,
!    taking cubic symmetry into account.
!    Given 2 orientation tensors, r1 and r2, the
!    misorientation angle (in rad) is: acos((tr(r1*r2^t)-1)/2), where "tr"
!    is tensor trace. the angle is [0,pi].
!  SOURCE

real(kind=rdef) :: rot(3,3), angle, tmp(3,3)
integer :: i

minang = 1.0e1 ! any number .gt. PI will do
angle  = 0.0

do i=1,24
  call cgca_csym(i,rot)
  tmp = matmul(rot,r2)
  !call cgca_mis(r1,matmul(rot,r2),angle)
  call cgca_mis(r1,tmp,angle)
  if (angle .lt. minang) minang=angle
end do

end subroutine cgca_miscsym

!*roboend*

end module cgca_m2rot


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

      subroutine ssor(u, rsd, frct, qs, rho_i, a, b, c, d,
     $                nx, nxmax, ny, nz)

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

c---------------------------------------------------------------------
c   to perform pseudo-time stepping SSOR iterations
c   for five nonlinear pde's.
c---------------------------------------------------------------------

      implicit none

      include 'header.h'
      integer          nx, nxmax, ny, nz
      double precision u(5,nxmax,ny,nz), rsd(5,nxmax,ny,nz),
     $                 frct(5,nxmax,ny,nz), qs(nxmax,ny,nz),
     $                 rho_i(nxmax,ny,nz),
     $                 a(5,5,2:nxmax-1,ny), b(5,5,2:nxmax-1,ny),
     $                 c(5,5,2:nxmax-1,ny), d(5,5,2:nxmax-1,ny)

c---------------------------------------------------------------------
c  local variables
c---------------------------------------------------------------------
      integer i, j, k, m
      double precision  tmp, tv(5,problem_size,problem_size)
      external timer_read
      double precision timer_read

      if (timeron) call timer_start(t_rhs)
      do k = 2, nz-1
        do j = 2, ny-1
          do i = 2, nx-1
            do m = 1, 5
              rsd(m,i,j,k) = dt * rsd(m,i,j,k)
            end do
          end do
        end do
      end do
      if (timeron) call timer_stop(t_rhs)

      do k = 2, nz-1
c---------------------------------------------------------------------
c   form the lower triangular part of the jacobian matrix
c---------------------------------------------------------------------
        if (timeron) call timer_start(t_jacld)
        call jacld(k, u, rho_i, qs, a, b, c, d, nx, nxmax, ny, nz)
        if (timeron) call timer_stop(t_jacld)

c---------------------------------------------------------------------
c   perform the lower triangular solution
c---------------------------------------------------------------------
        if (timeron) call timer_start(t_blts)
        call blts( nx, nxmax, ny, nz, k, omega, rsd, a, b, c, d)
        if (timeron) call timer_stop(t_blts)
      end do

      do k = nz-1, 2, -1
c---------------------------------------------------------------------
c   form the strictly upper triangular part of the jacobian matrix
c---------------------------------------------------------------------
        if (timeron) call timer_start(t_jacu)
        call jacu(k, u, rho_i, qs, a, b, c, d, nx, nxmax, ny, nz)
        if (timeron) call timer_stop(t_jacu)

c---------------------------------------------------------------------
c   perform the upper triangular solution
c---------------------------------------------------------------------
        if (timeron) call timer_start(t_buts)
        call buts( nx, nxmax, ny, nz, k, omega, rsd, tv, d, a, b, c)
        if (timeron) call timer_stop(t_buts)
      end do

c---------------------------------------------------------------------
c   update the variables
c---------------------------------------------------------------------

      tmp = 1.0d0 / ( omega * ( 2.0d0 - omega ) )
      if (timeron) call timer_start(t_add)
      do k = 2, nz-1
        do j = 2, ny-1
          do i = 2, nx-1
            do m = 1, 5
              u(m,i,j,k) = u(m,i,j,k) + tmp * rsd(m,i,j,k)
            end do
          end do
        end do
      end do
      if (timeron) call timer_stop(t_add)

c---------------------------------------------------------------------
c   compute the steady-state residuals
c---------------------------------------------------------------------
      if (timeron) call timer_start(t_rhs)
         call rhs(u, rsd, frct, qs, rho_i, nx, nxmax, ny, nz)
      if (timeron) call timer_stop(t_rhs)

      return
      end


      subroutine clawpack46_qinit(maxmx,maxmy,meqn,mbc,mx,my,
     &      xlower,ylower,dx,dy,q,maux,aux)
c     =====================================================
c
c     # Set initial conditions for q.
c     # Shallow water with radial dam break problem, h = hin inside
c     # circle specified in fdisc.f
c
      implicit none

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

      integer i,j
      double precision xc, yc

      do i = 1-mbc,mx+mbc
          xc = xlower + (i-0.5d0)*dx
          do j = 1-mbc,my+mbc
              yc = ylower + (j-0.5d0)*dy
              q(i,j,1) = 0.1d0 + exp(-200.d0*(xc**2 + yc**2))
              q(i,j,2) = 0.d0
              q(i,j,3) = 0.d0
          end do
      end do

      return
      end


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   EVB-QMDFF - RPMD molecular dynamics and rate constant calculations on
!               black-box generated potential energy surfaces
!
!   Copyright (c) 2021 by Julien Steffen (steffen@pctc.uni-kiel.de)
!                         Stefan Grimme (grimme@thch.uni-bonn.de) (QMDFF code)
!
!   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.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!
!     Subroutine matrix_exp: Return the expoential of a (square) matrix
!       using the scale and square algorithm.
!    Parameters:
!   M - The square matrix to exponentiate
!   n - The size of the matrix
!   j - The number of terms in the exponential to evaluate
!   k - The exponent of the power of two used to scale the matrix
!    Returns:
!   EM - The expoential of the given matrix
!    --> taken from RPMDrate
!
!    part of EVB
!
subroutine matrix_exp(M, n, j, k, EM)
    integer, intent(in)  :: n, j, k
    real*8, intent(in)   :: M(n,n)
    real*8, intent(out)   :: EM(n,n)

    real *8 :: tc(j+1), SM(n,n)
    integer p, i
    tc(1)=1
    do i=1,j
       tc(i+1)=tc(i)/dble(i)
    enddo

    !scale
    SM=M*(1./2.**k)
    EM=0.
    do i=1,n
       EM(i,i)=tc(j+1)
    enddo

    !taylor exp of scaled matrix
    do p=j,1,-1
       EM=matmul(SM,EM);
       do i=1,n
          EM(i,i)=EM(i,i)+tc(p)
       enddo
    enddo

    !square
    do p=1,k
       EM=matmul(EM,EM)
    enddo

end subroutine matrix_exp


      FUNCTION RAN2(IDUM)
      PARAMETER (M=714025,IA=1366,IC=150889,RM=1.4005112E-6)
      DIMENSION IR(97)
      DATA IFF /0/
      IF(IDUM.LT.0.OR.IFF.EQ.0)THEN
        IFF=1
        IDUM=MOD(IC-IDUM,M)
        DO 11 J=1,97
          IDUM=MOD(IA*IDUM+IC,M)
          IR(J)=IDUM
11      CONTINUE
        IDUM=MOD(IA*IDUM+IC,M)
        IY=IDUM
      ENDIF
      J=1+(97*IY)/M
      IF(J.GT.97.OR.J.LT.1)PAUSE
      IY=IR(J)
      RAN2=IY*RM
      IDUM=MOD(IA*IDUM+IC,M)
      IR(J)=IDUM
      RETURN
      END


cb::inverse
c
      program inverse
c
c********1*********2*********3*********4*********5*********6*********7**
c
c name:      inverse
c version:   200208.19
c author:    stephen j. frakes
c purpose:   to compute a geodetic inverse
c            and then display output information
c
c input parameters:
c -----------------
c
c output parameters:
c ------------------
c
c local variables and constants:
c ------------------------------
c answer           user prompt response
c b                semiminor axis polar (in meters)
c baz              azimuth back (in radians)
c buff             input char buffer array
c dd,dm,ds         temporary values for degrees, minutes, seconds
c dlon             temporary value for difference in longitude (radians)
c dmt,d_mt         char constants for meter units
c edist            ellipsoid distance (in meters)
c elips            ellipsoid choice
c esq              eccentricity squared for reference ellipsoid
c faz              azimuth forward (in radians)
c filout           output file name
c finv             reciprocal flattening
c hem              hemisphere flag for lat & lon entry
c ierror           error condition flag with d,m,s conversion
c lgh              length of buff() array
c option           user prompt response
c r1,r2            temporary variables
c ss               temporary variable
c tol              tolerance for conversion of seconds
c
c name1            name of station one
c ld1,lm1,sl1      latitude  sta one - degrees,minutes,seconds
c ald1,alm1,sl1    latitude  sta one - degrees,minutes,seconds
c lat1sn           latitude  sta one - sign (+/- 1)
c d_ns1            latitude  sta one - char ('N','S')
c lod1,lom1,slo1   longitude sta one - degrees,minutes,seconds
c alod1,alom1,slo1 longitude sta one - degrees,minutes,seconds
c lon1sn           longitude sta one - sign (+/- 1)
c d_ew1            longitude sta one - char ('E','W')
c iaz1,maz1,saz1   forward azimuth   - degrees,minutes,seconds
c isign1           forward azimuth   - flag  (+/- 1)
c glat1,glon1      station one       - (lat & lon in radians )
c p1,e1            standpoint one    - (lat & lon in radians )
c
c name2            name of station two
c ld2,lm2,sl2      latitude  sta two - degrees,minutes,seconds
c ald2,alm2,sl2    latitude  sta two - degrees,minutes,seconds
c lat2sn           latitude  sta two - sign (+/- 1)
c d_ns2            latitude  sta two - char ('N','S')
c lod2,lom2,slo2   longitude sta two - degrees,minutes,seconds
c alod2,alom2,slo2 longitude sta one - degrees,minutes,seconds
c lon2sn           longitude sta two - sign (+/- 1)
c d_ew2            longitude sta two - char ('E','W')
c iaz2,maz2,saz2   back azimuth      - degrees,minutes,seconds
c isign2           back azimuth      - flag  (+/- 1)
c glat2,glon2      station two       - (lat & lon in radians )
c p2,e2            forepoint two     - (lat & lon in radians )
c
c global variables and constants:
c -------------------------------
c a                semimajor axis equatorial (in meters)
c f                flattening
c pi               constant 3.14159....
c rad              constant 180.0/pi
c
c    this module called by:  n/a
c
c    this module calls:      elipss, getrad, inver1, todmsp
c    gethem, trim,   bufdms, gvalr8, gvali4, fixdms, gpnhri
c    datan,  write,  read,   dabs,   open,   stop
c
c    include files used:     n/a
c
c    common blocks used:     const, elipsoid
c
c    references:             see comments within subroutines
c
c    comments:
c
c********1*********2*********3*********4*********5*********6*********7**
c::modification history
c::1990mm.dd, sjf, creation of program
c::199412.15, bmt, creation of program on viper
c::200203.08, crs, modified by c.schwarz to correct spelling of Clarke
c::200207.15, rws, modified i/o & standardized program documentation
c::                added subs trim, bufdms, gethem, gvali4, gvalr8
c::200207.23, rws, replaced sub inver1 with gpnarc, gpnloa, gpnhri
c::200208.15, rws, fixed an error in bufdms
c::              - renamed ellips to elipss "common error" with dirct2
c::              - added FAZ & BAZ to printed output
c::200208.19, rws, added more error flags for web interface code
c::              - added logical nowebb
c::200208.xx, sjf, program version number 2.0
c********1*********2*********3*********4*********5*********6*********7**
ce::inverse
c
      implicit double precision (a-h, o-z)
      implicit integer (i-n)
c
      logical  nowebb
c
      character*1  answer,option,dmt,buff(50),hem
      character*6  d_ns1, d_ew1, d_ns2, d_ew2, d_mt
      character*30 filout,name1,name2,elips
c
      integer*4    ierror
      integer*4    lgh
c
      common/const/pi,rad
      common/elipsoid/a,f
c
c     ms_unix      0 = web version
c                  1 = ms_dos or unix version
c
      parameter   ( ms_unix = 0 )
c
      pi   = 4.d0*datan(1.d0)
      rad  = 180.d0/pi
      dmt  = 'm'
      d_mt = 'Meters'
c
      if( ms_unix.eq.1 )then
        nowebb = .true.
      else
        nowebb = .false.
      endif
c
    1 do 2 i=1,25
        write(*,*) '  '
    2 continue
c
    5 write(*,*) '  Program Inverse  -  Version 2.0 '
      write(*,*) '  '
      write(*,*) '  Ellipsoid options : '
      write(*,*) '  '
      write(*,*) '  1) GRS80 / WGS84  (NAD83) '
      write(*,*) '  2) Clarke 1866    (NAD27) '
      write(*,*) '  3) Any other ellipsoid '
      write(*,*) '  '
      write(*,*) '  Enter choice : '
      read(*,10) option
   10 format(a1)
c
      if(option.eq.'1') then
        a=6378137.d0
        f=1.d0/298.25722210088d0
        elips='GRS80 / WGS84  (NAD83)'
      elseif(option.eq.'2') then
        a=6378206.4d0
        f=1.d0/294.9786982138d0
        elips='Clarke 1866    (NAD27)'
      elseif(option.eq.'3') then
        call elipss (elips)
      else
        write(*,*) '  Enter 1, 2, or 3 !   Try again --'
        goto 5
      endif
c
      esq = f*(2.0d0-f)
c
      write(*,*) '  '
      write(*,*) '  '
      write(*,*) '  '
      write(*,*) '  '
c
   15 write(*,*) '  Enter First Station '
      write(*,16)
   16 format(18x,'(Separate D,M,S by blanks or commas)')
      write(*,*) 'hDD MM SS.sssss  Latitude :        (h default = N )'
   11 format(50a1)
c
   22 hem='N'
      read(*,11) buff
      call trim (buff,lgh,hem)
      call bufdms (buff,lgh,hem,dd,dm,ds,ierror)
c
      if( ierror.eq.0 )then
        irlat1 = 0
      else
        irlat1 = 1
        write(*,*) ' Invalid Latitude ... Please re-enter it '
        write(*,*) '  '
        if( nowebb )then
          goto 22
        endif
      endif
c
      ald1 = dd
      alm1 = dm
      sl1  = ds
c
      if( hem.eq.'N' ) then
        lat1sn = +1
      else
        lat1sn = -1
      endif
c
      write(*,*) 'hDDD MM SS.sssss Longitude :       (h default = W )'
c
   23 hem='W'
      read(*,11) buff
      call trim (buff,lgh,hem)
      call bufdms (buff,lgh,hem,dd,dm,ds,ierror)
c
      if( ierror.eq.0 )then
        irlon1 = 0
      else
        irlon1 = 1
        write(*,*) ' Invalid Longitude ... Please re-enter it '
        write(*,*) '  '
        if( nowebb )then
          goto 23
        endif
      endif
c
      alod1 = dd
      alom1 = dm
      slo1  = ds
c
      if( hem.eq.'E' ) then
        lon1sn = +1
      else
        lon1sn = -1
      endif
c
      call getrad(ald1, alm1, sl1, lat1sn, glat1)
      call getrad(alod1,alom1,slo1,lon1sn, glon1)
c
      write(*,*) '  '
      write(*,*) '  '
c
   20 write(*,*) '  Enter Second Station '
      write(*,16)
      write(*,*) 'hDD MM SS.sssss  Latitude :        (h default = N )'
c
   24 hem='N'
      read(*,11) buff
      call trim (buff,lgh,hem)
      call bufdms (buff,lgh,hem,dd,dm,ds,ierror)
c
      if( ierror.eq.0 )then
        irlat2 = 0
      else
        irlat2 = 1
        write(*,*) ' Invalid Latitude ... Please re-enter it '
        write(*,*) '  '
        if( nowebb )then
          goto 24
        endif
      endif
c
      ald2 = dd
      alm2 = dm
      sl2  = ds
c
      if( hem.eq.'N' ) then
        lat2sn = +1
      else
        lat2sn = -1
      endif
c
      write(*,*) 'hDDD MM SS.sssss Longitude :       (h default = W )'
c
   25 hem='W'
      read(*,11) buff
      call trim (buff,lgh,hem)
      call bufdms (buff,lgh,hem,dd,dm,ds,ierror)
c
      if( ierror.eq.0 )then
        irlon2 = 0
      else
        irlon2 = 1
        write(*,*) ' Invalid Longitude ... Please re-enter it '
        write(*,*) '  '
        if( nowebb )then
          goto 25
        endif
      endif
c
      alod2 = dd
      alom2 = dm
      slo2  = ds
c
      if( hem.eq.'E' )then
        lon2sn = +1
      else
        lon2sn = -1
      endif
c
      call getrad(ald2, alm2, sl2, lat2sn, glat2)
      call getrad(alod2,alom2,slo2,lon2sn, glon2)
c
      p1 = glat1
      e1 = glon1
      p2 = glat2
      e2 = glon2
c
      if( e1.lt.0.0d0 )then
        e1 = e1+2.0d0*pi
      endif
      if( e2.lt.0.0d0 )then
        e2 = e2+2.0d0*pi
      endif
c
c     compute the geodetic inverse
c
c ************************************************************
c *   replaced subroutine inver1 with gpnhri
c *
c *   call inver1 (glat1,glon1,glat2,glon2,faz,baz,edist)
c *
c ************************************************************
c
      call gpnhri (a,f,esq,pi,p1,e1,p2,e2,faz,baz,edist)
c
c     check for a non distance ... p1,e1 & p2,e2 equal zero ?
c
      if( edist.lt.0.00005d0 )then
        faz = 0.0d0
        baz = 0.0d0
      endif
c
c     set the tolerance (in seconds) for the azimuth conversion
c
      tol = 0.00005d0
c
      call todmsp(faz,iaz1,maz1,saz1,isign1)
      if(isign1.lt.0) then
        iaz1=359-iaz1
        maz1=59-maz1
        saz1=60.d0-saz1
      endif
      call fixdms ( iaz1, maz1, saz1, tol )
c
      call todmsp(baz,iaz2,maz2,saz2,isign2)
      if(isign2.lt.0) then
        iaz2=359-iaz2
        maz2=59-maz2
        saz2=60.d0-saz2
      endif
      call fixdms ( iaz2, maz2, saz2, tol )
c
      call todmsp(glat1, ld1,  lm1,  sl1,  lat1sn)
      call todmsp(glon1, lod1, lom1, slo1, lon1sn)
      call todmsp(glat2, ld2,  lm2,  sl2,  lat2sn)
      call todmsp(glon2, lod2, lom2, slo2, lon2sn)
c
      call hem_ns ( lat1sn, d_ns1 )
      call hem_ew ( lon1sn, d_ew1 )
      call hem_ns ( lat2sn, d_ns2 )
      call hem_ew ( lon2sn, d_ew2 )
c
      write(*,*) '  '
      write(*,*) '  '
      write(*,*) '  '
      write(*,*) '  '
      write(*,*) '  '
      write(*,49) elips
   49 format('  Ellipsoid : ',a30)
      finv=1.d0/f
      b=a*(1.d0-f)
      write(*,50) a,b,finv
   50 format('  Equatorial axis,    a   = ',f15.4,/,
     *       '  Polar axis,         b   = ',f15.4,/,
     *       '  Inverse flattening, 1/f = ',f16.11)
c
   18 format('    LAT = ',i3,1x,i2,1x,f8.5,1x,a6)
   19 format('    LON = ',i3,1x,i2,1x,f8.5,1x,a6)
c
      write(*,*) '  '
      write(*,*) '  First  Station : '
      write(*,*) '  ---------------- '
      write(*,18) ld1, lm1, sl1, d_ns1
      write(*,19) lod1,lom1,slo1,d_ew1
c
      write(*,*) '  '
      write(*,*) '  Second Station : '
      write(*,*) '  ---------------- '
      write(*,18) ld2, lm2, sl2, d_ns2
      write(*,19) lod2,lom2,slo2,d_ew2
c
   32 format('  Ellipsoidal distance     S = ',f14.4,1x,a1)
   34 format('  Forward azimuth        FAZ = ',i3,1x,i2,1x,f7.4,
     1       ' From North')
   35 format('  Back azimuth           BAZ = ',i3,1x,i2,1x,f7.4,
     1       ' From North')
c
      write(*,*) '  '
      write(*,34) iaz1,maz1,saz1
      write(*,35) iaz2,maz2,saz2
      write(*,32) edist,dmt
      write(*,*) '  '
      write(*,*) '  Do you want to save this output into a file (y/n)?'
      read(*,10) answer
c
      if( answer.eq.'Y'.or.answer.eq.'y' )then
   39   write(*,*) '  Enter the output filename : '
        read(*,40) filout
   40   format(a30)
        open(3,file=filout,status='new',err=99)
        goto 98
c
   99   write(*,*) '  File already exists, try again.'
        go to 39
c
   98   continue
        write(3,*) '  '
        write(3,49) elips
        finv=1.d0/f
        b=a*(1.d0-f)
        write(3,50) a,b,finv
        write(*,*) '  Enter the First Station name : '
        read(*,40) name1
        write(*,*) '  Enter the Second Station name : '
        read(*,40) name2
c
   41   format('  First  Station : ',a30)
   42   format('  Second Station : ',a30)
   84   format('  Error: First  Station ... Invalid Latitude  ')
   85   format('  Error: First  Station ... Invalid Longitude ')
   86   format('  Error: Second Station ... Invalid Latitude  ')
   87   format('  Error: Second Station ... Invalid Longitude ')
   88   format(1x,65(1h*))
   91   format('         DD(0-89) MM(0-59) SS(0-59.999...)  ')
   92   format('         DDD(0-359) MM(0-59) SS(0-59.999...)  ')
c
        write(3,*) '  '
        write(3,41) name1
        write(3,*) '  ---------------- '

        if( irlat1.eq.0 )then
          write(3,18) ld1, lm1, sl1, d_ns1
        else
          write(3,88)
          write(3,84)
          write(3,91)
          write(3,88)
        endif
c
        if( irlon1.eq.0 )then
          write(3,19) lod1,lom1,slo1,d_ew1
        else
          write(3,88)
          write(3,85)
          write(3,92)
          write(3,88)
        endif
c
        write(3,*) '  '
        write(3,42) name2
        write(3,*) '  ---------------- '
c
        if( irlat2.eq.0 )then
          write(3,18) ld2, lm2, sl2, d_ns2
        else
          write(3,88)
          write(3,86)
          write(3,91)
          write(3,88)
        endif
c
        if( irlon2.eq.0 )then
          write(3,19) lod2,lom2,slo2,d_ew2
        else
          write(3,88)
          write(3,87)
          write(3,92)
          write(3,88)
        endif
c
        write(3,*) '  '
        write(3,34) iaz1,maz1,saz1
        write(3,35) iaz2,maz2,saz2
        write(3,32) edist,dmt
        write(3,*) '  '
      endif
c
   80 write(*,*) '  '
      write(*,*) '  '
      write(*,*) '  '
      write(*,*) '  1) Another inverse, different ellipsoid.'
      write(*,*) '  2) Same ellipsoid, two new stations.'
      write(*,*) '  3) Same ellipsoid, same First Station.'
      write(*,*) '  4) Done.'
      write(*,*) '  '
      write(*,*) '  Enter choice : '
      read(*,10) answer
c
      if(     answer.eq.'1' )then
        goto 1
      elseif( answer.eq.'2' )then
        goto 15
      elseif( answer.eq.'3' )then
        goto 20
      else
        write(*,*) '  Thats all, folks!'
      endif

c     stop
      end

      subroutine bufdms (buff,lgh,hem,dd,dm,ds,ierror)
      implicit double precision (a-h, o-z)
      implicit integer (i-n)
c
      logical     done,flag
c
      character*1 buff(*),abuf(21)
      character*1 ch
      character*1 hem
      integer*4   ll,lgh
      integer*4   i4,id,im,is,icond,ierror
      real*8      x(5)
c
c     set the "error flag"
c
      ierror = 0
      icond  = 0
c
c     set defaults for dd,dm,ds
c
      dd = 0.0d0
      dm = 0.0d0
      ds = 0.0d0
c
c     set default limits for "hem" flag
c
      if(     hem.eq.'N' .or. hem.eq.'S' )then
        ddmax = 90.0d0
      elseif( hem.eq.'E' .or. hem.eq.'W' )then
        ddmax = 360.0d0
      elseif( hem.eq.'A' )then
        ddmax = 360.0d0
      elseif( hem.eq.'Z' )then
        ddmax = 180.0d0
      elseif( hem.eq.'*' )then
        ddmax  = 0.0d0
        ierror = 1
      else
        ddmax = 360.0d0
      endif
c
      do 1 i=1,5
        x(i) = 0.0d0
    1 continue
c
      icolon = 0
      ipoint = 0
      icount = 0
      flag   = .true.
      jlgh   = lgh
c
      do 2 i=1,jlgh
        if( buff(i).eq.':' )then
          icolon = icolon+1
        endif
        if( buff(i).eq.'.' )then
          ipoint = ipoint+1
          flag   = .false.
        endif
        if( flag )then
          icount = icount+1
        endif
    2 continue
c
      if( ipoint.eq.1 .and. icolon.eq.0 )then
c
c       load temp buffer
c
        do 3 i=1,jlgh
          abuf(i) = buff(i)
    3   continue
        abuf(jlgh+1) = '$'
        ll = jlgh
c
        call gvalr8 (abuf,ll,r8,icond)
c
        if( icount.ge.5 )then
c
c         value is a packed decimal of ==>  DDMMSS.sssss
c
          ss = r8/10000.0d0
          id = idint( ss )
c
          r8 = r8-10000.0d0*dble(float(id))
          ss = r8/100.0d0
          im = idint( ss )
c
          r8 = r8-100.0d0*dble(float(im))
        else
c
c         value is a decimal of ==>  .xx   X.xxx   X.
c
          id = idint( r8 )
          r8 = (r8-id)*60.0d0
          im = idint( r8 )
          r8 = (r8-im)*60.0d0
        endif
c
c       account for rounding error
c
        is = idnint( r8*1.0d5 )
        if( is.ge.6000000 )then
           r8 = 0.0d0
           im = im+1
        endif
c
        if( im.ge.60 )then
          im = 0
          id = id+1
        endif
c
        dd = dble( float( id ) )
        dm = dble( float( im ) )
        ds = r8
      else
c
c       buff() value is a d,m,s of ==>  NN:NN:XX.xxx
c
        k    = 0
        next = 1
        done = .false.
        ie   = jlgh
c
        do 100 j=1,5
          ib = next
          do 90 i=ib,ie
            ch   = buff(i)
            last = i
            if( i.eq.jlgh .or. ch.eq.':' )then
              if( i.eq.jlgh )then
                done = .true.
              endif
              if( ch.eq.':' )then
                last = i-1
              endif
              goto 91
            endif
   90     continue
          goto 98
c
   91     ipoint = 0
          ik     = 0
          do 92 i=next,last
            ik = ik+1
            ch = buff(i)
            if( ch.eq.'.' )then
              ipoint = ipoint+1
            endif
            abuf(ik) = buff(i)
   92     continue
          abuf(ik+1) = '$'
c
          ll = ik
          if( ipoint.eq.0 )then
            call gvali4 (abuf,ll,i4,icond)
            r8 = dble(float( i4 ))
          else
            call gvalr8 (abuf,ll,r8,icond)
          endif
c
          k    = k+1
          x(k) = r8
c
   98     if( done )then
            goto 101
          endif
c
          next = last
   99     next = next+1
          if( buff(next).eq.':' )then
            goto 99
          endif
  100   continue
c
c       load dd,dm,ds
c
  101   if( k.ge.1 )then
          dd = x(1)
        endif
c
        if( k.ge.2 )then
          dm = x(2)
        endif
c
        if( k.ge.3 )then
          ds = x(3)
        endif
      endif
c
      if( dd.gt.ddmax  .or.
     1    dm.ge.60.0d0 .or.
     1    ds.ge.60.0d0 )then
        ierror = 1
        dd = 0.0d0
        dm = 0.0d0
        ds = 0.0d0
      endif
c
      if( icond.ne.0 )then
        ierror = 1
      endif
c
      return
      end

      subroutine elipss (elips)
      implicit double precision(a-h,o-z)
      character*1  answer
      character*30 elips
      common/elipsoid/a,f
      write(*,*) '  Other Ellipsoids.'
      write(*,*) '  -----------------'
      write(*,*) '  '
      write(*,*) '  A) Airy 1858'
      write(*,*) '  B) Airy Modified'
      write(*,*) '  C) Australian National'
      write(*,*) '  D) Bessel 1841'
      write(*,*) '  E) Clarke 1880'
      write(*,*) '  F) Everest 1830'
      write(*,*) '  G) Everest Modified'
      write(*,*) '  H) Fisher 1960'
      write(*,*) '  I) Fisher 1968'
      write(*,*) '  J) Hough 1956'
      write(*,*) '  K) International (Hayford)'
      write(*,*) '  L) Krassovsky 1938'
      write(*,*) '  M) NWL-9D (WGS 66)'
      write(*,*) '  N) South American 1969'
      write(*,*) '  O) Soviet Geod. System 1985'
      write(*,*) '  P) WGS 72'
      write(*,*) '  Q-Z) User defined.'
      write(*,*) '  '
      write(*,*) '  Enter choice : '
      read(*,10) answer
   10 format(a1)
c
      if(answer.eq.'A'.or.answer.eq.'a') then
        a=6377563.396d0
        f=1.d0/299.3249646d0
        elips='Airy 1858'
      elseif(answer.eq.'B'.or.answer.eq.'b') then
        a=6377340.189d0
        f=1.d0/299.3249646d0
        elips='Airy Modified'
      elseif(answer.eq.'C'.or.answer.eq.'c') then
        a=6378160.d0
        f=1.d0/298.25d0
        elips='Australian National'
      elseif(answer.eq.'D'.or.answer.eq.'d') then
        a=6377397.155d0
        f=1.d0/299.1528128d0
        elips='Bessel 1841'
      elseif(answer.eq.'E'.or.answer.eq.'e') then
        a=6378249.145d0
        f=1.d0/293.465d0
        elips='Clarke 1880'
      elseif(answer.eq.'F'.or.answer.eq.'f') then
        a=6377276.345d0
        f=1.d0/300.8017d0
        elips='Everest 1830'
      elseif(answer.eq.'G'.or.answer.eq.'g') then
        a=6377304.063d0
        f=1.d0/300.8017d0
        elips='Everest Modified'
      elseif(answer.eq.'H'.or.answer.eq.'h') then
        a=6378166.d0
        f=1.d0/298.3d0
        elips='Fisher 1960'
      elseif(answer.eq.'I'.or.answer.eq.'i') then
        a=6378150.d0
        f=1.d0/298.3d0
        elips='Fisher 1968'
      elseif(answer.eq.'J'.or.answer.eq.'j') then
        a=6378270.d0
        f=1.d0/297.d0
        elips='Hough 1956'
      elseif(answer.eq.'K'.or.answer.eq.'k') then
        a=6378388.d0
        f=1.d0/297.d0
        elips='International (Hayford)'
      elseif(answer.eq.'L'.or.answer.eq.'l') then
        a=6378245.d0
        f=1.d0/298.3d0
        elips='Krassovsky 1938'
      elseif(answer.eq.'M'.or.answer.eq.'m') then
        a=6378145.d0
        f=1.d0/298.25d0
        elips='NWL-9D  (WGS 66)'
      elseif(answer.eq.'N'.or.answer.eq.'n') then
        a=6378160.d0
        f=1.d0/298.25d0
        elips='South American 1969'
      elseif(answer.eq.'O'.or.answer.eq.'o') then
        a=6378136.d0
        f=1.d0/298.257d0
        elips='Soviet Geod. System 1985'
      elseif(answer.eq.'P'.or.answer.eq.'p') then
        a=6378135.d0
        f=1.d0/298.26d0
        elips='WGS 72'
      else
        elips = 'User defined.'
c
        write(*,*) '  Enter Equatorial axis,   a : '
        read(*,*) a
        a  = dabs(a)
c
        write(*,*) '  Enter either Polar axis, b or '
        write(*,*) '  Reciprocal flattening,   1/f : '
        read(*,*) ss
        ss = dabs(ss)
c
        f = 0.0d0
        if( 200.0d0.le.ss .and. ss.le.310.0d0 )then
          f = 1.d0/ss
        elseif( 6000000.0d0.lt.ss .and. ss.lt.a )then
          f = (a-ss)/a
        else
          elips = 'Error: default GRS80 used.'
          a     = 6378137.0d0
          f     = 1.0d0/298.25722210088d0
        endif
      endif
c
      return
      end

      subroutine fixdms (ideg, min, sec, tol )
c
      implicit double precision (a-h, o-z)
      implicit integer (i-n)
c
c     test for seconds near 60.0-tol
c
      if( sec.ge.( 60.0d0-tol ) )then
        sec  = 0.0d0
        min  = min+1
      endif
c
c     test for minutes near 60
c
      if( min.ge.60 )then
        min  = 0
        ideg = ideg+1
      endif
c
c     test for degrees near 360
c
      if( ideg.ge.360 )then
        ideg = 0
      endif
c
      return
      end

      subroutine hem_ns ( lat_sn, hem )
      implicit integer (i-n)
      character*6  hem
c
      if( lat_sn.eq.1 ) then
        hem = 'North '
      else
        hem = 'South '
      endif
c
      return
      end
      subroutine hem_ew ( lon_sn, hem )
      implicit integer (i-n)
      character*6  hem
c
      if( lon_sn.eq.1 ) then
        hem = 'East  '
      else
        hem = 'West  '
      endif
c
      return
      end
      subroutine getrad(d,m,sec,isign,val)

*** comvert deg, min, sec to radians

      implicit double precision(a-h,j-z)
      common/const/pi,rad

      val=(d+m/60.d0+sec/3600.d0)/rad
      val=dble(isign)*val

      return
      end

CB::GPNARC
C
      SUBROUTINE GPNARC (AMAX,FLAT,ESQ,PI,P1,P2,ARC)
C
C********1*********2*********3*********4*********5*********6*********7*
C
C NAME:        GPNARC
C VERSION:     200005.26
C WRITTEN BY:  ROBERT (Sid) SAFFORD
C PURPOSE:     SUBROUTINE TO COMPUTE THE LENGTH OF A MERIDIONAL ARC
C              BETWEEN TWO LATITUDES
C
C INPUT PARAMETERS:
C -----------------
C AMAX         SEMI-MAJOR AXIS OF REFERENCE ELLIPSOID
C FLAT         FLATTENING (0.0033528 ... )
C ESQ          ECCENTRICITY SQUARED FOR REFERENCE ELLIPSOID
C PI           3.14159...
C P1           LAT STATION 1
C P2           LAT STATION 2
C
C OUTPUT PARAMETERS:
C ------------------
C ARC          GEODETIC DISTANCE
C
C LOCAL VARIABLES AND CONSTANTS:
C ------------------------------
C GLOBAL VARIABLES AND CONSTANTS:
C -------------------------------
C
C    MODULE CALLED BY:    GENERAL
C
C    THIS MODULE CALLS:
C       LLIBFORE/ OPEN,   CLOSE,  READ,   WRITE,  INQUIRE
C                 DABS,   DBLE,   FLOAT,  IABS,   CHAR,   ICHAR
C
C    INCLUDE FILES USED:
C    COMMON BLOCKS USED:
C
C    REFERENCES: Microsoft FORTRAN 4.10 Optimizing Compiler, 1988
C                MS-DOS Operating System
C    COMMENTS:
C********1*********2*********3*********4*********5*********6*********7*
C::MODIFICATION HISTORY
C::197507.05, RWS, VER 00 TENCOL RELEASED FOR FIELD USE
C::198311.20, RWS, VER 01 MTEN   RELEASED TO FIELD
C::198411.26, RWS, VER 07 MTEN2  RELEASED TO FIELD
C::1985xx.xx, RWS, CODE   CREATED
C::198506.10, RWS, WRK    ENHANCEMENTS RELEASED TO FIELD
C::198509.01, RWS, VER 11 MTEN3  RELEASED TO FIELD
C::198512.18, RWS, CODE   MODIFIED FOR MTEN3
C::198708.10, RWS, CODE   MODIFIED TO USE NEW MTEN4 GPN RECORD FORMAT
C::199112.31, RWS, VER 20 MTEN4 RELEASED TO FIELD
C::200001.13, RWS, VER 21 MTEN4 RELEASED TO FIELD
C::200005.26, RWS, CODE   RESTRUCTURED & DOCUMENTATION ADDED
C::200012.31, RWS, VER 23 MTEN5 RELEASED
C********1*********2*********3*********4*********5*********6*********7*
CE::GPNARC
C ---------------------------
C     M T E N  (VERSION 3)
C     M T E N  (VERSION 5.23)
C ---------------------------
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      LOGICAL  FLAG
C
      DATA TT/5.0D-15/
C
C     CHECK FOR A 90 DEGREE LOOKUP
C
      FLAG = .FALSE.
C
      S1 = DABS(P1)
      S2 = DABS(P2)
C
      IF( (PI/2.0D0-TT).LT.S2 .AND. S2.LT.(PI/2.0D0+TT) )THEN
        FLAG = .TRUE.
      ENDIF
C
      IF( S1.GT.TT )THEN
        FLAG = .FALSE.
      ENDIF
C
      DA = (P2-P1)
      S1 = 0.0D0
      S2 = 0.0D0
C
C     COMPUTE THE LENGTH OF A MERIDIONAL ARC BETWEEN TWO LATITUDES
C
      E2 = ESQ
      E4 = E2*E2
      E6 = E4*E2
      E8 = E6*E2
      EX = E8*E2
C
      T1 = E2*(003.0D0/4.0D0)
      T2 = E4*(015.0D0/64.0D0)
      T3 = E6*(035.0D0/512.0D0)
      T4 = E8*(315.0D0/16384.0D0)
      T5 = EX*(693.0D0/131072.0D0)
C
      A  = 1.0D0+T1+3.0D0*T2+10.0D0*T3+35.0D0*T4+126.0D0*T5
C
      IF( FLAG )THEN
        GOTO 1
      ENDIF
C
      B  = T1+4.0D0*T2+15.0D0*T3+56.0D0*T4+210.0D0*T5
      C  = T2+06.0D0*T3+28.0D0*T4+120.0D0*T5
      D  = T3+08.0D0*T4+045.0D0*T5
      E  = T4+010.0D0*T5
      F  = T5
C
      DB = DSIN(P2*2.0D0)-DSIN(P1*2.0D0)
      DC = DSIN(P2*4.0D0)-DSIN(P1*4.0D0)
      DD = DSIN(P2*6.0D0)-DSIN(P1*6.0D0)
      DE = DSIN(P2*8.0D0)-DSIN(P1*8.0D0)
      DF = DSIN(P2*10.0D0)-DSIN(P1*10.0D0)
C
C     COMPUTE THE S2 PART OF THE SERIES EXPANSION
C
      S2 = -DB*B/2.0D0+DC*C/4.0D0-DD*D/6.0D0+DE*E/8.0D0-DF*F/10.0D0
C
C     COMPUTE THE S1 PART OF THE SERIES EXPANSION
C
    1 S1 = DA*A
C
C     COMPUTE THE ARC LENGTH
C
      ARC = AMAX*(1.0D0-ESQ)*(S1+S2)
C
      RETURN
      END
cb::gpnhri
c
      subroutine gpnhri (a,f,esq,pi,p1,e1,p2,e2,az1,az2,s)
c
c********1*********2*********3*********4*********5*********6*********7*
c
c name:        gpnhri
c version:     200208.09
c written by:  robert (sid) safford
c purpose:     subroutine to compute helmert rainsford inverse problem
c
c     solution of the geodetic inverse problem after t. vincenty
c     modified rainsford's method with helmert's elliptical terms
c     effective in any azimuth and at any distance short of antipocal
c     from/to stations must not be the geographic pole.
c     parameter a is the semi-major axis of the reference ellipsoid
c     finv=1/f is the inverse flattening of the reference ellipsoid
c     latitudes and longitudes in radians positive north and west
c     forward and back azimuths returned in radians clockwise from south
c     geodesic distance s returned in units of semi-major axis a
c     programmed for ibm 360-195   09/23/75
c
c     note - note - note -
c     1. do not use for meridional arcs and be careful on the equator.
c     2. azimuths are from north(+) clockwise and
c     3. longitudes are positive east(+)
c
c input parameters:
c -----------------
c a            semi-major axis of reference ellipsoid      meters
c f            flattening (0.0033528...)
c esq          eccentricity squared
c pi           3.14159...
c p1           lat station 1                               radians
c e1           lon station 1                               radians
c p2           lat station 2                               radians
c e2           lon station 2                               radians
c
c output parameters:
c ------------------
c az1          azi at sta 1 -> sta 2                       radians
c az2          azi at sta 2 -> sta 1                       radians
c s            geodetic dist between sta(s) 1 & 2          meters
c
c local variables and constants:
c ------------------------------
c aa               constant from subroutine gpnloa
c alimit           equatorial arc distance along the equator   (radians)
c arc              meridional arc distance latitude p1 to p2 (in meters)
c az1              azimuth forward                          (in radians)
c az2              azimuth back                             (in radians)
c bb               constant from subroutine gpnloa
c dlon             temporary value for difference in longitude (radians)
c equ              equatorial distance                       (in meters)
c r1,r2            temporary variables
c s                ellipsoid distance                        (in meters)
c sms              equatorial - geodesic distance (S - s) "Sms"
c ss               temporary variable
c tol0             tolerance for checking computation value
c tol1             tolerance for checking a real zero value
c tol2             tolerance for close to zero value
c twopi            two times constant pi
c
c global variables and constants:
c -------------------------------
c
c    module called by:    general
c
c    this module calls:   gpnarc, gpnloa
c       llibfore/ dsin,   dcos,   dsqrt,  dabs,  datan2, write
c
c    include files used:
c    common blocks used:
c
c    references: microsoft fortran 4.10 optimizing compiler, 1988
c                ms-dos operating system
c    comments:
c********1*********2*********3*********4*********5*********6*********7*
c::modification history
c::197507.05, rws, ver 00 tencol released for field use
c::198311.20, rws, ver 01 mten   released to field
c::198411.26, rws, ver 07 mten2  released to field
c::198506.10, rws, wrk    enhancements released to field
c::198507.22, rws, code   modified for mten3
c::198509.01, rws, ver 11 mten3  released to field
c::198708.10, rws, code   modified to use new mten4 gpn record format
c::199112.31, rws, ver 20 mten4 released to field
c::200001.13, rws, ver 21 mten4 released to field
c::200005.26, rws, code   restructured & documentation added
c::200012.31, rws, ver 23 mten5 released
c::200104.09, rws, code   added to calblin program
c::200208.09, rws, code   added subroutines gpnarc & gpnloa
c********1*********2*********3*********4*********5*********6*********7*
ce::gpnhri
c  -------------------------------
c     m t e n  (version 3)
c              (version 4.22)
c              (version 5.23)
c  -------------------------------
c
      implicit real*8 (a-h,o-z)
c
      data tol0 /5.0d-15/
      data tol1 /5.0d-14/
      data tol2 /7.0d-03/
c
      twopi = 2.0d0*pi
c
c     test the longitude difference with tol1
c     tol1 is approximately 0.000000001 arc seconds
c
      ss = e2-e1
      if( dabs(ss).lt.tol1 )then
        e2 = e2+tol1
        write(*,*) ' longitudal difference is near zero '
c
        r2 = p2
        r1 = p1
        call gpnarc ( a, f, esq, pi, r1, r2, arc )
        s  = dabs( arc )
c
        if( p2.gt.p1 )then
          az1 = 0.0d0
          az2 = pi
        else
          az1 = pi
          az2 = 0.0d0
        endif
        return
      endif
c
c     test for longitude over 180 degrees
c
      dlon = e2-e1
c
      if( dlon.ge.0.0d0 )then
        if( pi.le.dlon .and. dlon.lt.twopi )then
          dlon = dlon-twopi
        endif
      else
        ss = dabs(dlon)
        if( pi.le.ss .and. ss.lt.twopi )then
          dlon = dlon+twopi
        endif
      endif
c
      ss = dabs( dlon )
      if( ss.gt.pi )then
c::     write(*,*) '  '
c::     write(*,*) ' Longitude difference over 180 degrees  '
c::     write(*,*) ' Turn it around '
        ss = twopi-ss
      endif
c
c     compute the limit in longitude (alimit), it is equal
c     to twice the distance from the equator to the pole,
c     as measured along the equator (east/ewst)
c
      alimit = pi*(1.0d0-f)
c
c     test for anti-nodal difference
c
      if( ss.ge.alimit )then
        r1 = dabs(p1)
        r2 = dabs(p2)
c
c       latitudes r1 & r2 are not near the equator
c
        if( r1.gt.tol2 .and. r2.gt.tol2 )then
          goto 60
        endif
c
c       longitude difference is greater than lift-off point
c       now check to see if  "both"  r1 & r2 are on equator
c
        if( r1.lt.tol1 .and. r2.gt.tol2 )then
          goto 60
        endif
        if( r2.lt.tol1 .and. r1.gt.tol2 )then
          goto 60
        endif
c
c       check for either r1 or r2 just off the equator but < tol2
c
        if( r1.gt.tol1. or. r2.gt.tol1 )then
          az1 = 0.0d0
          az2 = 0.0d0
          s   = 0.0d0
          return
        endif
c
c       compute the azimuth to anti-nodal point
c
c::     write(*,*) '  '
c::     write(*,*) ' Longitude difference beyond lift-off point '
c::     write(*,*) '  '
c
        call gpnloa (a,f,esq,pi,dlon,az1,az2,aa,bb,sms)
c
c       compute the equatorial distance & geodetic
c
        equ = a*dabs(dlon)
        s   = equ-sms
        return
      endif
c
   60 continue
c
      f0   = (1.0d0-f)
      b    = a*f0
      epsq = esq/(1.0d0-esq)
      f2   = f*f
      f3   = f*f2
      f4   = f*f3
c
c     the longitude difference
c
      dlon  = e2-e1
      ab    = dlon
      kount = 0
c
c     the reduced latitudes
c
      u1    = f0*dsin(p1)/dcos(p1)
      u2    = f0*dsin(p2)/dcos(p2)
c
      u1    = datan(u1)
      u2    = datan(u2)
c
      su1   = dsin(u1)
      cu1   = dcos(u1)
c
      su2   = dsin(u2)
      cu2   = dcos(u2)
c
c     counter for the iteration operation
c
    1 kount = kount+1
c
      clon  = dcos(ab)
      slon  = dsin(ab)
c
      csig  = su1*su2+cu1*cu2*clon
      ssig  = dsqrt((slon*cu2)**2+(su2*cu1-su1*cu2*clon)**2)
c
      sig   = datan2(ssig,csig)
      sinalf=cu1*cu2*slon/ssig
c
      w   = (1.0d0-sinalf*sinalf)
      t4  = w*w
      t6  = w*t4
c
c     the coefficients of type a
c
      ao  = f-f2*(1.0d0+f+f2)*w/4.0d0+3.0d0*f3*(1.0d0+
     1        9.0d0*f/4.0d0)*t4/16.0d0-25.0d0*f4*t6/128.0d0
      a2  = f2*(1.0d0+f+f2)*w/4.0d0-f3*(1.0d0+9.0d0*f/4.0d0)*t4/4.0d0+
     1        75.0d0*f4*t6/256.0d0
      a4  = f3*(1.0d0+9.0d0*f/4.0d0)*t4/32.0d0-15.0d0*f4*t6/256.0d0
      a6  = 5.0d0*f4*t6/768.0d0
c
c     the multiple angle functions
c
      qo  = 0.0d0
      if( w.gt.tol0 )then
        qo = -2.0d0*su1*su2/w
      endif
c
      q2  = csig+qo
      q4  = 2.0d0*q2*q2-1.0d0
      q6  = q2*(4.0d0*q2*q2-3.0d0)
      r2  = 2.0d0*ssig*csig
      r3  = ssig*(3.0d0-4.0d0*ssig*ssig)
c
c     the longitude difference
c
      s   = sinalf*(ao*sig+a2*ssig*q2+a4*r2*q4+a6*r3*q6)
      xz  = dlon+s
c
      xy  = dabs(xz-ab)
      ab  = dlon+s
c
      if( xy.lt.0.5d-13 )then
        goto 4
      endif
c
      if( kount.le.7 )then
        goto 1
      endif
c
c     the coefficients of type b
c
    4 z   = epsq*w
c
      bo  = 1.0d0+z*(1.0d0/4.0d0+z*(-3.0d0/64.0d0+z*(5.0d0/256.0d0-
     1         z*175.0d0/16384.0d0)))
      b2  = z*(-1.0d0/4.0d0+z*(1.0d0/16.0d0+z*(-15.0d0/512.0d0+
     1         z*35.0d0/2048.0d0)))
      b4  = z*z*(-1.0d0/128.0d0+z*(3.0d0/512.0d0-z*35.0d0/8192.0d0))
      b6  = z*z*z*(-1.0d0/1536.0d0+z*5.0d0/6144.0d0)
c
c     the distance in meters
c
      s   = b*(bo*sig+b2*ssig*q2+b4*r2*q4+b6*r3*q6)
c
c     first compute the az1 & az2 for along the equator
c
      if( dlon.gt.pi )then
        dlon = (dlon-2.0d0*pi)
      endif
c
      if( dabs(dlon).gt.pi )then
        dlon = (dlon+2.0d0*pi)
      endif
c
      az1 = pi/2.0d0
      if( dlon.lt.0.0d0 )then
        az1 = 3.0d0*az1
      endif
c
      az2 = az1+pi
      if( az2.gt.2.0d0*pi )then
        az2 = az2-2.0d0*pi
      endif
c
c     now compute the az1 & az2 for latitudes not on the equator
c
      if( .not.(dabs(su1).lt.tol0 .and. dabs(su2).lt.tol0) )then
        tana1 =  slon*cu2/(su2*cu1-clon*su1*cu2)
        tana2 =  slon*cu1/(su1*cu2-clon*su2*cu1)
        sina1 =  sinalf/cu1
        sina2 = -sinalf/cu2
c
c       azimuths from north,longitudes positive east
c
        az1   = datan2(sina1,sina1/tana1)
        az2   = pi-datan2(sina2,sina2/tana2)
      endif
c
      if( az1.lt.0.0d0 )then
        az1 = az1+2.0d0*pi
      endif
c
      if( az2.lt.0.0d0 )then
        az2 = az2+2.0d0*pi
      endif
c
      return
      end

CB::GPNLOA
C
      SUBROUTINE GPNLOA (AMAX,FLAT,ESQ,PI,DL,AZ1,AZ2,AO,BO,SMS)
C
C********1*********2*********3*********4*********5*********6*********7*
C
C NAME:        GPNLOA
C VERSION:     200005.26
C WRITTEN BY:  ROBERT (Sid) SAFFORD
C PURPOSE:     SUBROUTINE TO COMPUTE THE LIFF-OFF-AZIMUTH CONSTANTS
C
C INPUT PARAMETERS:
C -----------------
C AMAX         SEMI-MAJOR AXIS OF REFERENCE ELLIPSOID
C FLAT         FLATTENING (0.0033528 ... )
C ESQ          ECCENTRICITY SQUARED FOR REFERENCE ELLIPSOID
C PI           3.14159...
C DL           LON DIFFERENCE
C AZ1          AZI AT STA 1 -> STA 2
C
C OUTPUT PARAMETERS:
C ------------------
C AZ2          AZ2 AT STA 2 -> STA 1
C AO           CONST
C BO           CONST
C SMS          DISTANCE ... EQUATORIAL - GEODESIC  (S - s)   "SMS"
C
C LOCAL VARIABLES AND CONSTANTS:
C ------------------------------
C GLOBAL VARIABLES AND CONSTANTS:
C -------------------------------
C
C    MODULE CALLED BY:    GENERAL
C
C    THIS MODULE CALLS:
C       LLIBFORE/ DSIN,   DCOS,   DABS,   DASIN
C
C    INCLUDE FILES USED:
C    COMMON BLOCKS USED:
C
C    REFERENCES: Microsoft FORTRAN 4.10 Optimizing Compiler, 1988
C                MS-DOS Operating System
C    COMMENTS:
C********1*********2*********3*********4*********5*********6*********7*
C::MODIFICATION HISTORY
C::1985xx.xx, RWS, CODE   CREATED
C::198506.10, RWS, WRK    ENHANCEMENTS RELEASED TO FIELD
C::198509.01, RWS, VER 11 MTEN3  RELEASED TO FIELD
C::198512.18, RWS, CODE   MODIFIED FOR MTEN3
C::198708.10, RWS, CODE   MODIFIED TO USE NEW MTEN4 GPN RECORD FORMAT
C::199112.31, RWS, VER 20 MTEN4 RELEASED TO FIELD
C::200001.13, RWS, VER 21 MTEN4 RELEASED TO FIELD
C::200005.26, RWS, CODE   RESTRUCTURED & DOCUMENTATION ADDED
C::200012.31, RWS, VER 23 MTEN5 RELEASED
C********1*********2*********3*********4*********5*********6*********7*
CE::GPNLOA
C ---------------------------
C     M T E N  (VERSION 3)
C              (VERSION 4.22)
C              (VERSION 5.23)
C ---------------------------
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DATA TT/5.0D-13/
C
      DLON = DABS(DL)
      CONS = (PI-DLON)/(PI*FLAT)
      F    = FLAT
C
C     COMPUTE AN APPROXIMATE AZ
C
      AZ   = DASIN(CONS)
C
      T1   =    1.0D0
      T2   =  (-1.0D0/4.0D0)*F*(1.0D0+F+F*F)
      T4   =    3.0D0/16.0D0*F*F*(1.0D0+(9.0D0/4.0D0)*F)
      T6   = (-25.0D0/128.0D0)*F*F*F
C
      ITER = 0
    1 ITER = ITER+1
      S    = DCOS(AZ)
      C2   = S*S
C
C     COMPUTE NEW AO
C
      AO   = T1 + T2*C2 + T4*C2*C2 + T6*C2*C2*C2
      CS   = CONS/AO
      S    = DASIN(CS)
      IF( DABS(S-AZ).LT.TT )THEN
        GOTO 2
      ENDIF
C
      AZ   = S
      IF( ITER.LE.6 )THEN
        GOTO 1
      ENDIF
C
    2 AZ1  = S
      IF( DL.LT.0.0D0 )THEN
        AZ1 = 2.0D0*PI-AZ1
      ENDIF
C
      AZ2  = 2.0D0*PI-AZ1
C
C     EQUATORIAL - GEODESIC  (S - s)   "SMS"
C
      ESQP = ESQ/(1.0D0-ESQ)
      S    = DCOS(AZ1)
C
      U2   = ESQP*S*S
      U4   = U2*U2
      U6   = U4*U2
      U8   = U6*U2
C
      T1   =     1.0D0
      T2   =    (1.0D0/4.0D0)*U2
      T4   =   (-3.0D0/64.0D0)*U4
      T6   =    (5.0D0/256.0D0)*U6
      T8   = (-175.0D0/16384.0D0)*U8
C
      BO   = T1 + T2 + T4 + T6 + T8
      S    = DSIN(AZ1)
      SMS  = AMAX*PI*(1.0D0 - FLAT*DABS(S)*AO - BO*(1.0D0-FLAT))
C
      RETURN
      END
      subroutine gvali4 (buff,ll,vali4,icond)
      implicit     integer (i-n)
c
      logical      plus,sign,done,error
      character*1  buff(*)
      character*1  ch
c
c     integer*2    i
c     integer*2    l1
c
      integer*4    ich,icond
      integer*4    ll
      integer*4    vali4
c
      l1    = ll
      vali4 = 0
      icond = 0
      plus  = .true.
      sign  = .false.
      done  = .false.
      error = .false.
c
      i = 0
   10 i = i+1
      if( i.gt.l1 .or. done )then
        go to 1000
      else
        ch  = buff(i)
        ich = ichar( buff(i) )
      endif
c
      if(     ch.eq.'+' )then
c
c       enter on plus sign
c
        if( sign )then
          goto 150
        else
          sign = .true.
          goto 10
        endif
      elseif( ch.eq.'-' )then
c
c       enter on minus sign
c
        if( sign )then
          goto 150
        else
          sign = .true.
          plus = .false.
          goto 10
        endif
      elseif( ch.ge.'0' .and. ch.le.'9' )then
        goto 100
      elseif( ch.eq.' ' )then
c
c       enter on space -- ignore leading spaces
c
        if( .not.sign )then
          goto 10
        else
          buff(i) = '0'
          ich = 48
          goto 100
        endif
      elseif( ch.eq.':' )then
c
c       enter on colon -- ignore
c
        if( .not.sign )then
          goto 10
        else
          goto 1000
        endif
      elseif( ch.eq.'$' )then
c
c       enter on dollar "$"
c
        done = .true.
        goto 10
      else
c
c       something wrong
c
        goto 150
      endif
c
c     enter on numeric
c
  100 vali4 = 10*vali4+(ich-48)
      sign  = .true.
      goto 10
c
c     treat illegal character
c
  150 buff(i) = '0'
      vali4 = 0
      icond = 1
c
 1000 if( .not.plus )then
        vali4 = -vali4
      endif
c
      return
      end
      subroutine gvalr8 (buff,ll,valr8,icond)
      implicit     integer (i-n)
c
      logical      plus,sign,dpoint,done
c
      character*1  buff(*)
      character*1  ch
c
c     integer*2    i, ip
c     integer*2    l1
c     integer*2    nn, num, n48
c
      integer*4    ich,icond
      integer*4    ll
c
      real*8       ten
      real*8       valr8
      real*8       zero
c
      data zero,ten/0.0d0,10.0d0/
c
      n48     =  48
      l1      =  ll
      icond   =   0
      valr8   =  zero
      plus    = .true.
      sign    = .false.
      dpoint  = .false.
      done    = .false.
c
c     start loop thru buffer
c
      i = 0
   10 i = i+1
      if( i.gt.l1 .or. done )then
        go to 1000
      else
        ch  = buff(i)
        nn  = ichar( ch )
        ich = nn
      endif
c
      if(     ch.eq.'+' )then
c
c       enter on plus sign
c
        if( sign )then
          goto 150
        else
          sign = .true.
          goto 10
        endif
      elseif( ch.eq.'-' )then
c
c       enter on minus sign
c
        if( sign )then
          goto 150
        else
          sign = .true.
          plus = .false.
          goto 10
        endif
      elseif( ch.eq.'.' )then
c
c       enter on decimal point
c
        ip     = 0
        sign   = .true.
        dpoint = .true.
        goto 10
      elseif( ch.ge.'0' .and. ch.le.'9' )then
        goto 100
      elseif( ch.eq.' ' )then
c
c       enter on space
c
        if( .not.sign )then
          goto 10
        else
          buff(i) = '0'
          ich = 48
          goto 100
        endif
      elseif( ch.eq.':' .or. ch.eq.'$' )then
c
c       enter on colon or "$" sign
c
        done = .true.
        goto 10
      else
c
c       something wrong
c
        goto 150
      endif
c
c     enter on numeric
c
  100 sign = .true.
      if( dpoint )then
        ip = ip+1
      endif
c
      num   = ich
      valr8 = ten*valr8+dble(float( num-n48 ))
      goto 10
c
c     treat illegal character
c
  150 buff(i) = '0'
      valr8   =  0.0d0
      icond   =  1
c
 1000 if( dpoint )then
        valr8 =  valr8/(ten**ip)
      endif
c
      if( .not.plus )then
        valr8 = -valr8
      endif
c
      return
      end

      subroutine todmsp(val,id,im,s,isign)

*** convert position radians to deg,min,sec
*** range is [-pi to +pi]

      implicit double precision(a-h,o-z)
      common/const/pi,rad

    1 if(val.gt.pi) then
        val=val-pi-pi
        go to 1
      endif

    2 if(val.lt.-pi) then
        val=val+pi+pi
        go to 2
      endif

      if(val.lt.0.d0) then
        isign=-1
      else
        isign=+1
      endif

      s=dabs(val*rad)
      id=idint(s)
      s=(s-id)*60.d0
      im=idint(s)
      s=(s-im)*60.d0

*** account for rounding error

      is=idnint(s*1.d5)
      if(is.ge.6000000) then
        s=0.d0
        im=im+1
      endif
      if(im.ge.60) then
        im=0
        id=id+1
      endif

      return
      end

      subroutine trim (buff,lgh,hem)
c
      implicit integer (i-n)
      character*1 ch,hem
      character*1 buff(*)
      integer*4   lgh
c
      ibeg = 1
      do 10 i=1,50
        if( buff(i).ne.' ' )then
          goto 11
        endif
        ibeg = ibeg+1
   10 continue
   11 continue
      if( ibeg.ge.50 )then
        ibeg = 1
        buff(ibeg) = '0'
      endif
c
      iend = 50
      do 20 i=1,50
        j = 51-i
        if( buff(j).eq.' ' )then
          iend = iend-1
        else
          goto 21
        endif
   20 continue
   21 continue
c
      ch = buff(ibeg)
      if( hem.eq.'N' )then
        if( ch.eq.'N' .or. ch.eq.'n' .or. ch.eq.'+' )then
          hem = 'N'
          ibeg = ibeg+1
        endif
        if( ch.eq.'S' .or. ch.eq.'s' .or. ch.eq.'-' )then
          hem = 'S'
          ibeg = ibeg+1
        endif
c
c       check for wrong hemisphere entry
c
        if( ch.eq.'E' .or. ch.eq.'e' )then
          hem = '*'
          ibeg = ibeg+1
        endif
        if( ch.eq.'W' .or. ch.eq.'w' )then
          hem = '*'
          ibeg = ibeg+1
        endif
      elseif( hem.eq.'W' )then
        if( ch.eq.'E' .or. ch.eq.'e' .or. ch.eq.'+' )then
          hem = 'E'
          ibeg = ibeg+1
        endif
        if( ch.eq.'W' .or. ch.eq.'w' .or. ch.eq.'-' )then
          hem = 'W'
          ibeg = ibeg+1
        endif
c
c       check for wrong hemisphere entry
c
        if( ch.eq.'N' .or. ch.eq.'n' )then
          hem = '*'
          ibeg = ibeg+1
        endif
        if( ch.eq.'S' .or. ch.eq.'s' )then
          hem = '*'
          ibeg = ibeg+1
        endif
      elseif( hem.eq.'A' )then
        if( .not.('0'.le.ch .and. ch.le.'9') )then
          hem = '*'
          ibeg = ibeg+1
        endif
      else
c        do nothing
      endif
c
c
      do 30 i=ibeg,iend
        ch = buff(i)
c
        if(     ch.eq.':' .or. ch.eq.'.' )then
          goto 30
        elseif( ch.eq.' ' .or. ch.eq.',' )then
          buff(i) = ':'
        elseif( '0'.le.ch .and. ch.le.'9' )then
          goto 30
        else
          buff(i) = ':'
        endif
c
   30 continue
c
c     left justify buff() array to its first character position
c     also check for a ":" char in the starting position,
c     if found!!  skip it
c
      j  = 0
      ib = ibeg
      ie = iend
c
      do 40 i=ib,ie
        if( i.eq.ibeg .and. buff(i).eq.':' )then
c
c         move the 1st position pointer to the next char &
c         do not put ":" char in buff(j) array where j=1
c
          ibeg = ibeg+1
          goto 40
        endif
        j = j+1
        buff(j) = buff(i)
   40 continue
c
c
      lgh = iend-ibeg+1
      j   = lgh+1
      buff(j) = '$'
c
c     clean-up the rest of the buff() array
c
      do 50 i=j+1,50
        buff(i) = ' '
   50 continue
c
c     save a maximum of 20 characters
c
      if( lgh.gt.20 )then
        lgh = 20
        j   = lgh+1
        buff(j) = '$'
      endif
c
      return
      end


      subroutine metaer(twiss,ip,esclx,escly,im,imon,emon)
      use ffs
      use tffitcode
      implicit real*8(a-h,o-z)
      dimension twiss(nlat,-ndim:ndim,ntwissfun),
     $     imon(nmona,4),emon(nmona,*)
      include 'inc/common.inc'
c
      j=imon(im,2)
      n=imon(j,1)
      r11=twiss(n,ip,11)
      r12=twiss(n,ip,12)
      r21=twiss(n,ip,13)
      r22=twiss(n,ip,14)
      det=r11*r22-r12*r21
      if(det.gt.1d0) then
c       qr=sqrt((det-1d0)/det)
        qr=(det-1d0)/det
        un=sqrt(det)
        emon(j,3)=sqrt(
     z          (r12**2 + (r22/twiss(n,ip,2))**2)*qr + un**2
     z                  ) *tgauss() *esclx
        emon(j,4)=sqrt(
     z           un**2 + (r21**2 + (r22/twiss(n,ip,5))**2)*qr
     z                  ) *tgauss() *escly
c       c2(1)=(-r12*c4(1) + r22*c4(2))*qr +  un*c4(3)
c       c2(2)=( r11*c4(1) - r21*c4(2))*qr              + un*c4(4)
c       c2(3)=   un*c4(1)                 +(r21*c4(3)  +r22*c4(4))*qr
c       c2(4)=               un*c4(2)     +(r11*c4(3)  +r12*c4(4))*qr
      else
        un=sqrt(1d0-det)
        emon(j,3)=sqrt(
     z          un**2 +  r22**2 + (r12/twiss(n,ip,5))**2
     z                  ) *tgauss() *esclx
        emon(j,4)=sqrt(
     z          r11**2 + (r12/twiss(n,ip,2))**2+ un**2
     z                  ) *tgauss() *escly
c       c2(1)=  un*c4(1)               -r22*c4(3)  +r12*c4(4)
c       c2(2)=            + un*c4(2)   +r21*c4(3)  -r11*c4(4)
c       c2(3)= r11*c4(1)  +r12*c4(2)   + un*c4(3)
c       c2(4)= r21*c4(1)  +r22*c4(2)               + un*c4(4)
      endif
      return
      end