!*==dlatrd.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b DLATRD reduces the first nb rows and columns of a symmetric/Hermitian matrix A to real tridiagonal form by an orthogonal similarity transformation.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DLATRD + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )
!
!       .. Scalar Arguments ..
!       CHARACTER          UPLO
!       INTEGER            LDA, LDW, N, NB
!       ..
!       .. Array Arguments ..
!       DOUBLE PRECISION   A( LDA, * ), E( * ), TAU( * ), W( LDW, * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DLATRD reduces NB rows and columns of a real symmetric matrix A to
!> symmetric tridiagonal form by an orthogonal similarity
!> transformation Q**T * A * Q, and returns the matrices V and W which are
!> needed to apply the transformation to the unreduced part of A.
!>
!> If UPLO = 'U', DLATRD reduces the last NB rows and columns of a
!> matrix, of which the upper triangle is supplied;
!> if UPLO = 'L', DLATRD reduces the first NB rows and columns of a
!> matrix, of which the lower triangle is supplied.
!>
!> This is an auxiliary routine called by DSYTRD.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] UPLO
!> \verbatim
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          symmetric matrix A is stored:
!>          = 'U': Upper triangular
!>          = 'L': Lower triangular
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix A.
!> \endverbatim
!>
!> \param[in] NB
!> \verbatim
!>          NB is INTEGER
!>          The number of rows and columns to be reduced.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!>          n-by-n upper triangular part of A contains the upper
!>          triangular part of the matrix A, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading n-by-n lower triangular part of A contains the lower
!>          triangular part of the matrix A, and the strictly upper
!>          triangular part of A is not referenced.
!>          On exit:
!>          if UPLO = 'U', the last NB columns have been reduced to
!>            tridiagonal form, with the diagonal elements overwriting
!>            the diagonal elements of A; the elements above the diagonal
!>            with the array TAU, represent the orthogonal matrix Q as a
!>            product of elementary reflectors;
!>          if UPLO = 'L', the first NB columns have been reduced to
!>            tridiagonal form, with the diagonal elements overwriting
!>            the diagonal elements of A; the elements below the diagonal
!>            with the array TAU, represent the  orthogonal matrix Q as a
!>            product of elementary reflectors.
!>          See Further Details.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= (1,N).
!> \endverbatim
!>
!> \param[out] E
!> \verbatim
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>          If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal
!>          elements of the last NB columns of the reduced matrix;
!>          if UPLO = 'L', E(1:nb) contains the subdiagonal elements of
!>          the first NB columns of the reduced matrix.
!> \endverbatim
!>
!> \param[out] TAU
!> \verbatim
!>          TAU is DOUBLE PRECISION array, dimension (N-1)
!>          The scalar factors of the elementary reflectors, stored in
!>          TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.
!>          See Further Details.
!> \endverbatim
!>
!> \param[out] W
!> \verbatim
!>          W is DOUBLE PRECISION array, dimension (LDW,NB)
!>          The n-by-nb matrix W required to update the unreduced part
!>          of A.
!> \endverbatim
!>
!> \param[in] LDW
!> \verbatim
!>          LDW is INTEGER
!>          The leading dimension of the array W. LDW >= max(1,N).
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup doubleOTHERauxiliary
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  If UPLO = 'U', the matrix Q is represented as a product of elementary
!>  reflectors
!>
!>     Q = H(n) H(n-1) . . . H(n-nb+1).
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - tau * v * v**T
!>
!>  where tau is a real scalar, and v is a real vector with
!>  v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),
!>  and tau in TAU(i-1).
!>
!>  If UPLO = 'L', the matrix Q is represented as a product of elementary
!>  reflectors
!>
!>     Q = H(1) H(2) . . . H(nb).
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - tau * v * v**T
!>
!>  where tau is a real scalar, and v is a real vector with
!>  v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
!>  and tau in TAU(i).
!>
!>  The elements of the vectors v together form the n-by-nb matrix V
!>  which is needed, with W, to apply the transformation to the unreduced
!>  part of the matrix, using a symmetric rank-2k update of the form:
!>  A := A - V*W**T - W*V**T.
!>
!>  The contents of A on exit are illustrated by the following examples
!>  with n = 5 and nb = 2:
!>
!>  if UPLO = 'U':                       if UPLO = 'L':
!>
!>    (  a   a   a   v4  v5 )              (  d                  )
!>    (      a   a   v4  v5 )              (  1   d              )
!>    (          a   1   v5 )              (  v1  1   a          )
!>    (              d   1  )              (  v1  v2  a   a      )
!>    (                  d  )              (  v1  v2  a   a   a  )
!>
!>  where d denotes a diagonal element of the reduced matrix, a denotes
!>  an element of the original matrix that is unchanged, and vi denotes
!>  an element of the vector defining H(i).
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE DLATRD(Uplo,N,Nb,A,Lda,E,Tau,W,Ldw)
      IMPLICIT NONE
!*--DLATRD202
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Uplo
      INTEGER Lda , Ldw , N , Nb
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION A(Lda,*) , E(*) , Tau(*) , W(Ldw,*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ZERO , ONE , HALF
      PARAMETER (ZERO=0.0D+0,ONE=1.0D+0,HALF=0.5D+0)
!     ..
!     .. Local Scalars ..
      INTEGER i , iw
      DOUBLE PRECISION alpha
!     ..
!     .. External Subroutines ..
      EXTERNAL DAXPY , DGEMV , DLARFG , DSCAL , DSYMV
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      DOUBLE PRECISION DDOT
      EXTERNAL LSAME , DDOT
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MIN
!     ..
!     .. Executable Statements ..
!
!     Quick return if possible
!
      IF ( N<=0 ) RETURN
!
      IF ( LSAME(Uplo,'U') ) THEN
!
!        Reduce last NB columns of upper triangle
!
         DO i = N , N - Nb + 1 , -1
            iw = i - N + Nb
            IF ( i<N ) THEN
!
!              Update A(1:i,i)
!
               CALL DGEMV('No transpose',i,N-i,-ONE,A(1,i+1),Lda,       &
     &                    W(i,iw+1),Ldw,ONE,A(1,i),1)
               CALL DGEMV('No transpose',i,N-i,-ONE,W(1,iw+1),Ldw,      &
     &                    A(i,i+1),Lda,ONE,A(1,i),1)
            ENDIF
            IF ( i>1 ) THEN
!
!              Generate elementary reflector H(i) to annihilate
!              A(1:i-2,i)
!
               CALL DLARFG(i-1,A(i-1,i),A(1,i),1,Tau(i-1))
               E(i-1) = A(i-1,i)
               A(i-1,i) = ONE
!
!              Compute W(1:i-1,i)
!
               CALL DSYMV('Upper',i-1,ONE,A,Lda,A(1,i),1,ZERO,W(1,iw),1)
               IF ( i<N ) THEN
                  CALL DGEMV('Transpose',i-1,N-i,ONE,W(1,iw+1),Ldw,     &
     &                       A(1,i),1,ZERO,W(i+1,iw),1)
                  CALL DGEMV('No transpose',i-1,N-i,-ONE,A(1,i+1),Lda,  &
     &                       W(i+1,iw),1,ONE,W(1,iw),1)
                  CALL DGEMV('Transpose',i-1,N-i,ONE,A(1,i+1),Lda,A(1,i)&
     &                       ,1,ZERO,W(i+1,iw),1)
                  CALL DGEMV('No transpose',i-1,N-i,-ONE,W(1,iw+1),Ldw, &
     &                       W(i+1,iw),1,ONE,W(1,iw),1)
               ENDIF
               CALL DSCAL(i-1,Tau(i-1),W(1,iw),1)
               alpha = -HALF*Tau(i-1)*DDOT(i-1,W(1,iw),1,A(1,i),1)
               CALL DAXPY(i-1,alpha,A(1,i),1,W(1,iw),1)
            ENDIF
!
         ENDDO
      ELSE
!
!        Reduce first NB columns of lower triangle
!
         DO i = 1 , Nb
!
!           Update A(i:n,i)
!
            CALL DGEMV('No transpose',N-i+1,i-1,-ONE,A(i,1),Lda,W(i,1), &
     &                 Ldw,ONE,A(i,i),1)
            CALL DGEMV('No transpose',N-i+1,i-1,-ONE,W(i,1),Ldw,A(i,1), &
     &                 Lda,ONE,A(i,i),1)
            IF ( i<N ) THEN
!
!              Generate elementary reflector H(i) to annihilate
!              A(i+2:n,i)
!
               CALL DLARFG(N-i,A(i+1,i),A(MIN(i+2,N),i),1,Tau(i))
               E(i) = A(i+1,i)
               A(i+1,i) = ONE
!
!              Compute W(i+1:n,i)
!
               CALL DSYMV('Lower',N-i,ONE,A(i+1,i+1),Lda,A(i+1,i),1,    &
     &                    ZERO,W(i+1,i),1)
               CALL DGEMV('Transpose',N-i,i-1,ONE,W(i+1,1),Ldw,A(i+1,i),&
     &                    1,ZERO,W(1,i),1)
               CALL DGEMV('No transpose',N-i,i-1,-ONE,A(i+1,1),Lda,     &
     &                    W(1,i),1,ONE,W(i+1,i),1)
               CALL DGEMV('Transpose',N-i,i-1,ONE,A(i+1,1),Lda,A(i+1,i),&
     &                    1,ZERO,W(1,i),1)
               CALL DGEMV('No transpose',N-i,i-1,-ONE,W(i+1,1),Ldw,     &
     &                    W(1,i),1,ONE,W(i+1,i),1)
               CALL DSCAL(N-i,Tau(i),W(i+1,i),1)
               alpha = -HALF*Tau(i)*DDOT(N-i,W(i+1,i),1,A(i+1,i),1)
               CALL DAXPY(N-i,alpha,A(i+1,i),1,W(i+1,i),1)
            ENDIF
!
         ENDDO
      ENDIF
!
!
!     End of DLATRD
!
      END SUBROUTINE DLATRD


      SUBROUTINE GCF(GAMMCF,A,X,GLN)
      PARAMETER (ITMAX=100,EPS=3.E-7)
      GLN=GAMMLN(A)
      GOLD=0.
      A0=1.
      A1=X
      B0=0.
      B1=1.
      FAC=1.
      DO 11 N=1,ITMAX
        AN=FLOAT(N)
        ANA=AN-A
        A0=(A1+A0*ANA)*FAC
        B0=(B1+B0*ANA)*FAC
        ANF=AN*FAC
        A1=X*A0+ANF*A1
        B1=X*B0+ANF*B1
        IF(A1.NE.0.)THEN
          FAC=1./A1
          G=B1*FAC
          IF(ABS((G-GOLD)/G).LT.EPS)GO TO 1
          GOLD=G
        ENDIF
11    CONTINUE
      PAUSE 'A too large, ITMAX too small'
1     GAMMCF=EXP(-X+A*ALOG(X)-GLN)*G
      RETURN
      END


      subroutine ofeld(a,b,c,nocon)
!     to obtain points in characteristic network
      use kinddefine
      use contr, only:ie
      implicit none
!
      interface
       function fmv(psi)
        use kinddefine
        implicit none
        real(kind=K8) :: fmv
        real(kind=K8), intent(in) :: psi
       end function fmv
      end interface
!
      integer(kind=K4) :: i
      integer(kind=K4),intent(out) :: nocon
      real(kind=K8),dimension(5),intent(in) :: a,b
      real(kind=K8),dimension(5),intent(out) :: c
      real(kind=K8) :: a1,a2,a3,dtn,fm3,fsy1,fsy2,fsy3,half,hdpsi,hpsi3
      real(kind=K8) :: ht3,one,p1,p2,psi3
      real(kind=K8) :: t1,t2,t3,temp,tn2,tna,tnb,tni,told,two,x3,y3,zro
      data zro/0.0d+0/,one/1.d+0/,two/2.d+0/,half/5.d-1/
      a1=dasin(one/a(3))
      a2=dasin(one/b(3))
      t1=a(5)
      t2=b(5)
      if (ie .eq. 0) goto 8
      if (a(2) .eq. zro) goto 5
      fsy1=dsin(a(5))/a(2)/a(3)
      goto 6
5     t1=zro
      fsy1=a(5)
6     if (b(2) .eq. zro) goto 7
      fsy2=dsin(b(5))/b(2)/b(3)
      goto 8
7     t2=zro
      fsy2=b(5)
8     tni=dtan(t1-a1)
      if (b(3) .ne. one) tn2=dtan(t2+a2)
      i=-1
      hdpsi=half*(a(4)-b(4))
      ht3=half*(t1+t2)+hdpsi
      t3=ht3-half*ie*hdpsi
      hpsi3=half*(a(4)+b(4)+t1-t2)
      psi3=hpsi3+half*ie*(t1-t2)
      c(3)=fmv(psi3)
      told=t3
1     i=i+1
      fm3=c(3)
      a3=dasin(one/c(3))
      tna=half*(tni+dtan(t3-a3))
      if (b(3) .ne. one) tnb=half*(dtan(t3+a3)+tn2)
      if (b(3) .eq. one) tnb=two*dtan(t3+a3)
      dtn=tnb-tna
      x3=(b(1)*tnb-a(1)*tna+a(2)-b(2))/dtn
      y3=(a(2)*tnb-b(2)*tna+(b(1)-a(1))*tna*tnb)/dtn
      if ((ie .eq. 0) .or. (dabs(y3) .lt. 1.d-9)) goto 4
      fsy3=dsin(t3)/y3/fm3
      p1=half*(fsy1+fsy3)*(x3-a(1))*dsqrt(one+tna**2)
      p2=half*(fsy2+fsy3)*(x3-b(1))*dsqrt(one+tnb**2)
      t3=ht3+half*(p1-p2)
      psi3=hpsi3+half*(p1+p2)
      c(3)=fmv(psi3)
      if (dabs(t3-told) .gt. 1.d-9) goto 2
      if (dabs(c(3)-fm3) .lt. 1.d-9) goto 4
2     if (i .eq. 40) goto 3
      temp=t3
      t3=(t3+told)*half
      told=temp
      goto 1
3     nocon=1
4     c(1)=x3
      c(2)=y3
      c(4)=psi3
      c(5)=t3
      end subroutine ofeld


C SUBROUTINE ECH               (NEXT)
      SUBROUTINE ECH(ZSUM)
C
C     ECH - CALCULATES THE MUTUAL IMPEDANCE BETWEEN LINEAR DIPOLE
C        ELEMENTS IN ECHELON OF EQUAL LENGTHS.
C     SEE THE REFERENCES IN SUBROUTINES GAIN AND COLL.
C
      COMPLEX CSU1, CSU2, CSUZP, CSV1, CSV2, CSVZP, CSZ1, ZE, ZSUM
C
      COMMON /CON /D2R, DCL, GAMA, PI, PI2, PIO2, R2D, RO, VOFL
C
      COMMON /CUR /DIJ, EIL, HIJ, KODE
C
C.......................................................................
      D2 = DIJ * * 2
      HML = HIJ - EIL
      HPL = HIJ + EIL
      T = SQRT (D2 + HML * * 2)
      UZ = PI2 * (T + HML)
      VZ = PI2 * (T - HML)
      T = SQRT (D2 + HPL * * 2)
      UZP = PI2 * (T - HPL)
      VZP = PI2 * (T + HPL)
      TS = HIJ
      T = SQRT (D2 + TS * * 2)
      U1 = PI2 * (T + TS)
      V1 = PI2 * (T - TS)
      TS = HIJ + 2.0 * EIL
      T = SQRT (D2 + TS * * 2)
      U2 = PI2 * (T - TS)
      V2 = PI2 * (T + TS)
      TS = HIJ + 3.0 * EIL
      T = SQRT (D2 + TS * * 2)
      U4 = PI2 * (T - TS)
      V4 = PI2 * (T + TS)
      CSU1 = CSZ1 (U1)
      CSV1 = CSZ1 (V1)
      CSU2 = CSZ1 (U2)
      CSV2 = CSZ1 (V2)
      CSUZP = CSZ1 (UZP)
      CSVZP = CSZ1 (VZP)
      ZSUM = CMPLX (0.0, 0.0)
      T = PI2 * (EIL - HIJ)
      ZE = CMPLX (COS (T), SIN (T))
      ZSUM=ZSUM + CONJG(ZE)*(CSZ1(UZ) - CSU1) + ZE*(CSZ1(VZ) - CSV1)
      T = PI2 * (EIL + HIJ)
      ZE = CMPLX (COS (T), SIN (T))
      ZSUM = ZSUM + CONJG (ZE) * (CSUZP - CSU2) + ZE * (CSVZP - CSV2)
      T = PI2 * ( - EIL - HIJ)
      ZE = CMPLX (COS (T), SIN (T))
      ZSUM=ZSUM + CONJG(ZE)*( -CSU1 + CSVZP) + ZE*( -CSV1 + CSUZP)
      T = PI2 * (3.0 * EIL + HIJ)
      ZE = CMPLX (COS (T), SIN (T))
      ZSUM=ZSUM + CONJG(ZE)*( -CSU2+CSZ1(U4)) + ZE*( -CSV2+CSZ1(V4))
      TS = 2.0 * COS (PI2 * EIL)
      T = PI2 * HIJ
      ZE = CMPLX (COS (T), SIN (T))
      ZSUM=ZSUM+TS*CONJG(ZE)*(-CSV1+CSUZP)+TS*ZE*(-CSU1+CSVZP)
      T = PI2 * (2.0 * EIL + HIJ)
      ZE = CMPLX (COS (T), SIN (T))
      ZSUM=ZSUM + TS*CONJG(ZE)*(CSUZP - CSU2) + TS*ZE*(CSVZP-CSV2)
      IF (KODE .GT. 0) GO TO 100
      ZSUM = ZSUM * 15.0
      GO TO 105
 100  ZSUM = ZSUM * 30.0 / (1.0 - COS (2.0 * PI2 * EIL))
 105  RETURN
      END


      SUBROUTINE SB03OR( DISCR, LTRANS, N, M, S, LDS, A, LDA, C, LDC,
     $                   SCALE, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the solution of the Sylvester equations
C
C        op(S)'*X + X*op(A) = scale*C, if DISCR = .FALSE.  or
C
C        op(S)'*X*op(A) - X = scale*C, if DISCR = .TRUE.
C
C     where op(K) = K or K' (i.e., the transpose of the matrix K), S is
C     an N-by-N block upper triangular matrix with one-by-one and
C     two-by-two blocks on the diagonal, A is an M-by-M matrix (M = 1 or
C     M = 2), X and C are each N-by-M matrices, and scale is an output
C     scale factor, set less than or equal to 1 to avoid overflow in X.
C     The solution X is overwritten on C.
C
C     SB03OR  is a service routine for the Lyapunov solver  SB03OT.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DISCR   LOGICAL
C             Specifies the equation to be solved:
C             = .FALSE.:  op(S)'*X + X*op(A) = scale*C;
C             = .TRUE. :  op(S)'*X*op(A) - X = scale*C.
C
C     LTRANS  LOGICAL
C             Specifies the form of op(K) to be used, as follows:
C             = .FALSE.:  op(K) = K    (No transpose);
C             = .TRUE. :  op(K) = K**T (Transpose).
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix  S  and also the number of rows of
C             matrices  X and C.  N >= 0.
C
C     M       (input) INTEGER
C             The order of the matrix  A  and also the number of columns
C             of matrices  X and C.  M = 1 or M = 2.
C
C     S       (input) DOUBLE PRECISION array, dimension (LDS,N)
C             The leading  N-by-N  upper Hessenberg part of the array  S
C             must contain the block upper triangular matrix. The
C             elements below the upper Hessenberg part of the array  S
C             are not referenced.  The array  S  must not contain
C             diagonal blocks larger than two-by-two and the two-by-two
C             blocks must only correspond to complex conjugate pairs of
C             eigenvalues, not to real eigenvalues.
C
C     LDS     INTEGER
C             The leading dimension of array S.  LDS >= MAX(1,N).
C
C     A       (input) DOUBLE PRECISION array, dimension (LDS,M)
C             The leading  M-by-M  part of this array must contain a
C             given matrix, where M = 1 or M = 2.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= M.
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,M)
C             On entry, C must contain an N-by-M matrix, where M = 1 or
C             M = 2.
C             On exit, C contains the N-by-M matrix X, the solution of
C             the Sylvester equation.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,N).
C
C     SCALE   (output) DOUBLE PRECISION
C             The scale factor, scale, set less than or equal to 1 to
C             prevent the solution overflowing.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             = 1:  if DISCR = .FALSE., and S and -A have common
C                   eigenvalues, or if DISCR = .TRUE., and S and A have
C                   eigenvalues whose product is equal to unity;
C                   a solution has been computed using slightly
C                   perturbed values.
C
C     METHOD
C
C     The LAPACK scheme for solving Sylvester equations is adapted.
C
C     REFERENCES
C
C     [1] Hammarling, S.J.
C         Numerical solution of the stable, non-negative definite
C         Lyapunov equation.
C         IMA J. Num. Anal., 2, pp. 303-325, 1982.
C
C     NUMERICAL ASPECTS
C                               2
C     The algorithm requires 0(N M) operations and is backward stable.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997.
C     Supersedes Release 2.0 routines SB03CW and SB03CX by
C     Sven Hammarling, NAG Ltd, United Kingdom, Oct. 1986.
C     Partly based on routine PLYAP4 by A. Varga, University of Bochum,
C     May 1992.
C
C     REVISIONS
C
C     December 1997, April 1998, May 1999, April 2000.
C
C     KEYWORDS
C
C     Lyapunov equation, orthogonal transformation, real Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C     .. Scalar Arguments ..
      LOGICAL            DISCR, LTRANS
      INTEGER            INFO, LDA, LDS, LDC, M, N
      DOUBLE PRECISION   SCALE
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), S( LDS, * )
C     .. Local Scalars ..
      LOGICAL            TBYT
      INTEGER            DL, INFOM, ISGN, J, L, L1, L2, L2P1, LNEXT
      DOUBLE PRECISION   G11, G12, G21, G22, SCALOC, XNORM
C     ..
C     .. Local Arrays ..
      DOUBLE PRECISION   AT( 2, 2 ), VEC( 2, 2 ), X( 2, 2 )
C     ..
C     .. External Functions ..
      DOUBLE PRECISION   DDOT
      EXTERNAL           DDOT
C     ..
C     .. External Subroutines ..
      EXTERNAL           DLASY2, DSCAL, SB04PX, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
C     ..
C     .. Executable Statements ..
C
      INFO = 0
C
C     Test the input scalar arguments.
C
      IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( .NOT.( M.EQ.1 .OR. M.EQ.2 ) ) THEN
         INFO = -4
      ELSE IF( LDS.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDA.LT.M ) THEN
         INFO = -8
      ELSE IF( LDC.LT.MAX( 1, N ) ) THEN
         INFO = -10
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'SB03OR', -INFO )
         RETURN
      END IF
C
      SCALE = ONE
C
C     Quick return if possible.
C
      IF ( N.EQ.0 )
     $   RETURN
C
      ISGN = 1
      TBYT = M.EQ.2
      INFOM = 0
C
C     Construct A'.
C
      AT(1,1) = A(1,1)
      IF ( TBYT ) THEN
         AT(1,2) = A(2,1)
         AT(2,1) = A(1,2)
         AT(2,2) = A(2,2)
      END IF
C
      IF ( LTRANS ) THEN
C
C        Start row loop (index = L).
C        L1 (L2) : row index of the first (last) row of X(L).
C
         LNEXT = N
C
         DO 20 L = N, 1, -1
            IF( L.GT.LNEXT )
     $         GO TO 20
            L1 = L
            L2 = L
            IF( L.GT.1 ) THEN
               IF( S( L, L-1 ).NE.ZERO )
     $            L1 = L1 - 1
               LNEXT = L1 - 1
            END IF
            DL = L2 - L1 + 1
            L2P1 = MIN( L2+1, N )
C
            IF ( DISCR ) THEN
C
C              Solve  S*X*A' - X = scale*C.
C
C              The L-th block of X is determined from
C
C              S(L,L)*X(L)*A' - X(L) = C(L) - R(L),
C
C              where
C
C                      N
C              R(L) = SUM [S(L,J)*X(J)] * A' .
C                    J=L+1
C
               G11 = -DDOT( N-L2, S( L1, L2P1 ), LDS, C( L2P1, 1 ), 1 )
               IF ( TBYT ) THEN
                  G12 = -DDOT( N-L2, S( L1, L2P1 ), LDS, C( L2P1, 2 ),
     $                         1 )
                  VEC( 1, 1 ) = C( L1, 1 ) + G11*AT(1,1) + G12*AT(2,1)
                  VEC( 1, 2 ) = C( L1, 2 ) + G11*AT(1,2) + G12*AT(2,2)
               ELSE
                  VEC (1, 1 ) = C( L1, 1 ) + G11*AT(1,1)
               END IF
               IF ( DL.NE.1 ) THEN
                  G21 = -DDOT( N-L2, S( L2, L2P1 ), LDS, C( L2P1, 1 ),
     $                         1 )
                  IF ( TBYT ) THEN
                     G22 = -DDOT( N-L2, S( L2, L2P1 ), LDS,
     $                            C( L2P1, 2 ), 1 )
                     VEC( 2, 1 ) = C( L2, 1 ) + G21*AT(1,1) +
     $                                          G22*AT(2,1)
                     VEC( 2, 2 ) = C( L2, 2 ) + G21*AT(1,2) +
     $                                          G22*AT(2,2)
                  ELSE
                     VEC( 2, 1 ) = C( L2, 1 ) + G21*AT(1,1)
                  END IF
               END IF
               CALL SB04PX( .FALSE., .FALSE., -ISGN, DL, M, S( L1, L1 ),
     $                      LDS, AT, 2, VEC, 2, SCALOC, X, 2, XNORM,
     $                      INFO )
            ELSE
C
C              Solve  S*X + X*A' = scale*C.
C
C              The L-th block of X is determined from
C
C              S(L,L)*X(L) + X(L)*A' = C(L) - R(L),
C
C              where
C                       N
C              R(L) =  SUM S(L,J)*X(J) .
C                     J=L+1
C
               VEC( 1, 1 ) = C( L1, 1 ) -
     $                       DDOT( N-L2, S( L1, L2P1 ), LDS,
     $                             C( L2P1, 1 ), 1 )
               IF ( TBYT )
     $            VEC( 1, 2 ) = C( L1, 2 ) -
     $                          DDOT( N-L2, S( L1, L2P1 ), LDS,
     $                                C( L2P1, 2 ), 1 )
C
               IF ( DL.NE.1 ) THEN
                  VEC( 2, 1 ) = C( L2, 1 ) -
     $                          DDOT( N-L2, S( L2, L2P1 ), LDS,
     $                                C( L2P1, 1 ), 1 )
                  IF ( TBYT )
     $               VEC( 2, 2 ) = C( L2, 2 ) -
     $                             DDOT( N-L2, S( L2, L2P1 ), LDS,
     $                                   C( L2P1, 2 ), 1 )
               END IF
               CALL DLASY2( .FALSE., .FALSE., ISGN, DL, M, S( L1, L1 ),
     $                      LDS, AT, 2, VEC, 2, SCALOC, X, 2, XNORM,
     $                      INFO )
            END IF
            INFOM = MAX( INFO, INFOM )
            IF ( SCALOC.NE.ONE ) THEN
C
               DO 10 J = 1, M
                  CALL DSCAL( N, SCALOC, C( 1, J ), 1 )
   10          CONTINUE
C
               SCALE = SCALE*SCALOC
            END IF
            C( L1, 1 ) = X( 1, 1 )
            IF ( TBYT ) C( L1, 2 ) = X( 1, 2 )
            IF ( DL.NE.1 ) THEN
               C( L2, 1 ) = X( 2, 1 )
               IF ( TBYT ) C( L2, 2 ) = X( 2, 2 )
            END IF
   20    CONTINUE
C
      ELSE
C
C        Start row loop (index = L).
C        L1 (L2) : row index of the first (last) row of X(L).
C
         LNEXT = 1
C
         DO 40 L = 1, N
            IF( L.LT.LNEXT )
     $         GO TO 40
            L1 = L
            L2 = L
            IF( L.LT.N ) THEN
               IF( S( L+1, L ).NE.ZERO )
     $            L2 = L2 + 1
               LNEXT = L2 + 1
            END IF
            DL = L2 - L1 + 1
C
            IF ( DISCR ) THEN
C
C              Solve  A'*X'*S - X' = scale*C'.
C
C              The L-th block of X is determined from
C
C              A'*X(L)'*S(L,L) - X(L)' = C(L)' - R(L),
C
C              where
C
C                          L-1
C              R(L) = A' * SUM [X(J)'*S(J,L)] .
C                          J=1
C
               G11 = -DDOT( L1-1, C, 1, S( 1, L1 ), 1 )
               IF ( TBYT ) THEN
                  G21 = -DDOT( L1-1, C( 1, 2 ), 1, S( 1, L1 ), 1 )
                  VEC( 1, 1 ) = C( L1, 1 ) + AT(1,1)*G11 + AT(1,2)*G21
                  VEC( 2, 1 ) = C( L1, 2 ) + AT(2,1)*G11 + AT(2,2)*G21
               ELSE
                  VEC (1, 1 ) = C( L1, 1 ) + AT(1,1)*G11
               END IF
               IF ( DL .NE. 1 ) THEN
                  G12 = -DDOT( L1-1, C, 1, S( 1, L2 ), 1 )
                  IF ( TBYT ) THEN
                     G22 = -DDOT( L1-1, C( 1, 2 ), 1, S( 1, L2 ), 1 )
                     VEC( 1, 2 ) = C( L2, 1 ) + AT(1,1)*G12 +
     $                                          AT(1,2)*G22
                     VEC( 2, 2 ) = C( L2, 2 ) + AT(2,1)*G12 +
     $                                          AT(2,2)*G22
                  ELSE
                     VEC( 1, 2 ) = C( L2, 1 ) + AT(1,1)*G12
                  END IF
               END IF
               CALL SB04PX( .FALSE., .FALSE., -ISGN, M, DL, AT, 2,
     $                      S( L1, L1 ), LDS, VEC, 2, SCALOC, X, 2,
     $                      XNORM, INFO )
            ELSE
C
C              Solve  A'*X' + X'*S = scale*C'.
C
C              The L-th block of X is determined from
C
C              A'*X(L)' + X(L)'*S(L,L) = C(L)' - R(L),
C
C              where
C                     L-1
C              R(L) = SUM [X(J)'*S(J,L)].
C                     J=1
C
               VEC( 1, 1 ) = C( L1, 1 ) -
     $                       DDOT( L1-1, C, 1, S( 1, L1 ), 1 )
               IF ( TBYT )
     $            VEC( 2, 1 ) = C( L1, 2 ) -
     $                          DDOT( L1-1, C( 1, 2 ), 1, S( 1, L1 ), 1)
C
               IF ( DL.NE.1 ) THEN
                  VEC( 1, 2 ) = C( L2, 1 ) -
     $                          DDOT( L1-1, C, 1, S( 1, L2 ), 1 )
                  IF ( TBYT )
     $            VEC( 2, 2 ) = C( L2, 2 ) -
     $                          DDOT( L1-1, C( 1, 2 ), 1, S( 1, L2 ), 1)
               END IF
               CALL DLASY2( .FALSE., .FALSE., ISGN, M, DL, AT, 2,
     $                      S( L1, L1 ), LDS, VEC, 2, SCALOC, X, 2,
     $                      XNORM, INFO )
            END IF
            INFOM = MAX( INFO, INFOM )
            IF ( SCALOC.NE.ONE ) THEN
C
               DO 30 J = 1, M
                  CALL DSCAL( N, SCALOC, C( 1, J ), 1 )
   30          CONTINUE
C
               SCALE = SCALE*SCALOC
            END IF
            C( L1, 1 ) = X( 1, 1 )
            IF ( TBYT ) C( L1, 2 ) = X( 2, 1 )
            IF ( DL.NE.1 ) THEN
               C( L2, 1 ) = X( 1, 2 )
               IF ( TBYT ) C( L2, 2 ) = X( 2, 2 )
            END IF
   40    CONTINUE
      END IF
C
      INFO = INFOM
      RETURN
C *** Last line of SB03OR ***
      END


!=============================================================================!
        module diff
!
!  Finite Difference coefficient of various orders
!
!=============================================================================!
!.... First derivatives
!=============================================================================!

!.... fourth order central difference ( 1 2 x 4 5 )

        real, parameter :: ga1 =  8.333333333333333333333E-02
        real, parameter :: ga2 = -6.666666666666666666667E-01
        real, parameter :: ga3 =  6.666666666666666666667E-01
        real, parameter :: ga4 = -8.333333333333333333333E-02

!.... fourth order one-sided ( x 2 3 4 5 )

        real, parameter :: gc1 = -2.083333333333333333333E+00
        real, parameter :: gc2 =  4.000000000000000000000E+00
        real, parameter :: gc3 = -3.000000000000000000000E+00
        real, parameter :: gc4 =  1.333333333333333333333E+00
        real, parameter :: gc5 = -2.500000000000000000000E-01

!.... fourth order biased difference ( 1 x 2 3 4 5 )

        real, parameter :: gb1 = -2.500000000000000000000E-01
        real, parameter :: gb2 = -8.333333333333333333333E-01
        real, parameter :: gb3 =  1.500000000000000000000E+00
        real, parameter :: gb4 = -5.000000000000000000000E-01
        real, parameter :: gb5 =  8.333333333333333333333E-02

!.... sixth order one-sided ( x 2 3 4 5 6 7 )

        real, parameter :: ge1 = -2.450000000000000000000E+00
        real, parameter :: ge2 =  6.000000000000000000000E+00
        real, parameter :: ge3 = -7.500000000000000000000E+00
        real, parameter :: ge4 =  6.666666666666666666667E+00
        real, parameter :: ge5 = -3.750000000000000000000E+00
        real, parameter :: ge6 =  1.200000000000000000000E+00
        real, parameter :: ge7 = -1.666666666666666666667E-01

!.... sixth order one-pt biased ( 1 x 3 4 5 6 7 )

        real, parameter :: gf1 = -1.666666666666666666667E-01
        real, parameter :: gf2 = -1.283333333333333333333E+00
        real, parameter :: gf3 =  2.500000000000000000000E+00
        real, parameter :: gf4 = -1.666666666666666666667E+00
        real, parameter :: gf5 =  8.333333333333333333333E-01
        real, parameter :: gf6 = -2.500000000000000000000E-01
        real, parameter :: gf7 =  3.333333333333333333333E-02

!==============================================================================
!.... The following stencils are Carpenter's stable and third
!.... order accurate boundary treatment for the explicit fourth
!.... order interior scheme.
!==============================================================================

!.... third order one-sided [Carpenter] ( x 2 3 4 5 6)

        real, parameter :: gg1 = -1.8760320556207377229
        real, parameter :: gg2 =  3.185383225577892867
        real, parameter :: gg3 = -1.8145456794375275725
        real, parameter :: gg4 =  0.5916582410526027442
        real, parameter :: gg5 = -0.10105206800050562464
        real, parameter :: gg6 =  0.014588336428275308769

!.... third order biased [Carpenter] ( 1 x 3 4 5 )

        real, parameter :: gh1 = -0.38425423267792540204
        real, parameter :: gh2 = -0.29063894776734868107
        real, parameter :: gh3 =  0.6717647845153154114
        real, parameter :: gh4 =  0.07108165983739987271
        real, parameter :: gh5 = -0.07363071876172424507
        real, parameter :: gh6 =  0.00567745485428304409

!.... third order biased [Carpenter] ( 1 2 x 4 5 )

        real, parameter :: gi1 =  0.18288527868682620658
        real, parameter :: gi2 = -1.0800147541745551643
        real, parameter :: gi3 =  0.6578728964966252582
        real, parameter :: gi4 =  0.17761704868919314564
        real, parameter :: gi5 =  0.0767798363958275586
        real, parameter :: gi6 = -0.015140306093917004671

!.... third order biased [Carpenter] ( 1 2 3 x 5 )

        real, parameter :: gj1 = -0.03418371033652918578
        real, parameter :: gj2 =  0.22482902574010312173
        real, parameter :: gj3 = -0.8908123329284539625
        real, parameter :: gj4 =  0.16529994771003501478
        real, parameter :: gj5 =  0.6134395520875252998
        real, parameter :: gj6 = -0.07857248227268028806

!=============================================================================!
!.... Second derivatives
!=============================================================================!

!.... fourth order central difference

        real, parameter :: da1 = -8.333333333333333333333E-02
        real, parameter :: da2 =  1.333333333333333333333E+00
        real, parameter :: da3 = -2.500000000000000000000E+00
        real, parameter :: da4 =  1.333333333333333333333E+00
        real, parameter :: da5 = -8.333333333333333333333E-02

!.... third order biased difference

        real, parameter :: db1 =  9.166666666666666666667E-01
        real, parameter :: db2 = -1.666666666666666666667E+00
        real, parameter :: db3 =  5.000000000000000000000E-01
        real, parameter :: db4 =  3.333333333333333333333E-01
        real, parameter :: db5 = -8.333333333333333333333E-02

!.... fourth order one-sided (assumes f'=0) [not smooth]

        real, parameter :: dc1 = -5.763888888888888888889E+00
        real, parameter :: dc2 =  8.000000000000000000000E+00
        real, parameter :: dc3 = -3.000000000000000000000E+00
        real, parameter :: dc4 =  8.888888888888888888889E-01
        real, parameter :: dc5 = -1.250000000000000000000E-01

!.... third order one-sided

        real, parameter :: dd1 =  2.916666666666666666667E+00
        real, parameter :: dd2 = -8.666666666666666666667E+00
        real, parameter :: dd3 =  9.500000000000000000000E+00
        real, parameter :: dd4 = -4.666666666666666666667E+00
        real, parameter :: dd5 =  9.166666666666666666667E-01

!=============================================================================!
!.... Fourth derivatives
!=============================================================================!

!.... second-order, fourth derivative

        real, parameter :: fb1 =  1.000000000000000E+00
        real, parameter :: fb2 = -4.000000000000000E+00
        real, parameter :: fb3 =  6.000000000000000E+00
        real, parameter :: fb4 = -4.000000000000000E+00
        real, parameter :: fb5 =  1.000000000000000E+00

!.... fourth-order, fourth derivative

        real, parameter :: fa1 = -1.666666666666667E-01
        real, parameter :: fa2 =  2.000000000000000E+00
        real, parameter :: fa3 = -6.500000000000000E+00
        real, parameter :: fa4 =  9.333333333333333E+00
        real, parameter :: fa5 = -6.500000000000000E+00
        real, parameter :: fa6 =  2.000000000000000E+00
        real, parameter :: fa7 = -1.666666666666667E-01

!.... sixth-order, fourth derivative

        real, parameter :: fc1 =  2.916666666666667E-02
        real, parameter :: fc2 = -4.000000000000000E-01
        real, parameter :: fc3 =  2.816666666666667E+00
        real, parameter :: fc4 = -8.133333333333333E+00
        real, parameter :: fc5 =  1.137500000000000E+01
        real, parameter :: fc6 = -8.133333333333333E+00
        real, parameter :: fc7 =  2.816666666666667E+00
        real, parameter :: fc8 = -4.000000000000000E-01
        real, parameter :: fc9 =  2.916666666666667E-02

        end module diff


program MarsCrustalThickness
!-------------------------------------------------------------------------------
!
!	This program will compute the relief along the crust-mantle interface that
!	is needed to explain the martian gravity field. This crustal thickness model
!	is "anchored" by chosing a minimum crustal thickness.
!
!	In this program, the maximum spherical harmonic degree that is used
!	when calculating the relief raised to the nth power is the input spherical
!   harmonic degree. This is not entirely correct, as the relief raised to the
!   nth power generates a spherical harmonic field up to lmax*n. However, as it
!   is also not correct to assume that the topo and gravity field are
!   bandlimited with a maximum spherical harmonic degree of lmax, this
!   approximation is probably ok, espeically considering that the iterations
!	are filtered.
!
!	In order to improve stability when iterating for the Moho relief, the following iterative
!	scheme is used:
!
!		h3 = (h2+h1)/2
!		h4 = f(h3)
!
!	where "h" represents the moho relife, and "f" represents the SHTOOLS
!   funcion "BAtoHilm".
!
!	Copyright (c) 2015, Mark A. Wieczorek
!	All rights reserved.
!
!-------------------------------------------------------------------------------
	use SHTOOLS
	use PLANETSCONSTANTS

	implicit none
	real*8 :: 	r0, mass, rho_crust, rho_mantle, pi, gm, thinnest(2), &
			d, t0, delta, delta_max, thick_delta, param(8), grav, &
			r_grav, interval, rref, timein, timeout, max_thick, min_thick
	real*8, allocatable ::	topo_grid(:,:), moho_grid(:,:), moho_grid2(:,:), &
	        moho_grid3(:,:), temp_grid(:,:), topo_c(:,:,:), moho_c(:,:,:), &
	        bc(:,:,:), ba(:,:,:), cilm(:,:,:), pot(:,:,:), misfit(:,:,:)
	integer ::	l, m, lmax, i, nmax, nlat, nlong, gridtype, astat(12), n_out, &
			iter, j, r1, lmaxp, lmaxt, filter_type, half, degmax, sampling
	character*120 ::	grav_file, moho_out, thick_grid_out, topo_file, &
	        misfit_file

	print*,  "rho_crust (kg/m3) > "
	read(*,*) rho_crust
	print*, "rho_mantle (kg/m3) > "
	read(*,*) rho_mantle

	pi = acos(-1.0d0)
	delta_max = 5.0d0
	grav = Grav_constant

	gridtype = 3
	if (gridtype == 2) then
		sampling = 1
	elseif (gridtype == 3) then
		sampling = 2
	else
		stop
	endif

	nmax = 7	! nmax of Wieczorek and Phillips (1998)

	print*, "Input filter type (1) Minimum amplitude, (2) minimum curvature, (0) no filter "
	read(*,*) filter_type
	if (filter_type /= 0 ) then
		print*, "Degree at which the filter is 1/2 "
		read(*,*) half
	endif

	grav_file = "../../ExampleDataFiles/gmm3_120_sha.tab"
	topo_file = "../../ExampleDataFiles/MarsTopo719.shape"

	print*, "Remove degree 1 topo coefficients from Bouguer Correction? (0:no, 1:yes) > "
	read(*,*) r1

	print*, "maximum degree to compute Moho relief to >"
	read(*,*) degmax

	lmax = 2 * degmax ! this partially takes into account aliasing problems. Technically, it should be nmax*degmax

	nlat = 2*lmax+2
	nlong = 2*nlat

	print*, "Minimum assumed crustal thickness (km) > "
	read(*,*) t0
	t0 = t0 * 1.0d3

	print*, "Moho spherical harmonic coeficient output filename > "
	read(*,*) moho_out
	print*, "Grid spacing for output crustal thickness map (degrees) > "
	read(*,*) interval
	print*, "gridded crustal thickness output filename >"
	read(*,*) thick_grid_out
	print*, "Gravity misfit spherical harmonic filename >"
	read(*,*) misfit_file

	call cpu_time(timein)

	allocate(topo_grid(nlat, nlong), stat = astat(1))
	allocate(moho_grid(nlat, nlong), stat = astat(2))
	allocate(moho_grid2(nlat, nlong), stat = astat(3))
	allocate(moho_grid3(nlat, nlong), stat = astat(4))
	allocate(temp_grid(nlat, nlong), stat = astat(5))
	allocate(topo_c(2,degmax+1,degmax+1), stat = astat(6))
	allocate(moho_c(2,degmax+1,degmax+1), stat = astat(7))
	allocate(bc(2,degmax+1,degmax+1), stat = astat(8))
	allocate(ba(2,degmax+1,degmax+1), stat = astat(9))
	allocate(cilm(2,degmax+1,degmax+1), stat = astat(10))
	allocate(pot(2,degmax+1,degmax+1), stat = astat(11))
	allocate(misfit(2,degmax+1,degmax+1), stat = astat(12))

	if (sum(astat(1:12)) /= 0) then
		print*, "Problem allocating arrays."
		stop
	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Read topo and grav files
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	print*, "Reading data from ", grav_file
	call SHRead(grav_file, pot, lmaxp, header=param(1:2))

	gm = param(2) * 1.d9
	r_grav = param(1) * 1.d3
	mass = gm/grav

	print*, "Mass (kg) = ", mass
	print*, "Average surface gravity (m/s2) = ", gm/r_grav**2
	print*, "Lmax of gravitational potential file = ", lmaxp

	print*, "Reading data from ", topo_file
	call SHRead(topo_file, topo_c, lmaxt)
	print*, "Lmax of topography file = ", lmaxt

	r0 = topo_c(1,1,1)
	print*, "r0 (km) = ", r0/1.d3

	! Downward continue gravity coefficients from 3397 to MPR

	do l=2, lmaxp
		pot(1:2,l+1,1:l+1) = pot(1:2,l+1,1:l+1) * (r_grav/r0)**l
	enddo

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Create Bouger anomaly up to degree nmax
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	print*, "Creating Bouger anomaly"

	call MakeGridDH(topo_grid, n_out, topo_c, lmax, norm = 1, sampling = sampling, csphase = 1, lmax_calc = degmax)

	print*, "Maximum Topo (km) = ", maxval(topo_grid(1:nlat, 1:nlong))/1.d3
	print*, "Minimum Topo (km) = ", minval(topo_grid(1:nlat, 1:nlong))/1.d3

	call CilmPlus(bc, topo_grid, degmax, nmax, mass, rref, rho_crust, gridtype, n = nlat)

	ba = pot - bc	! This is the bouguer anomaly

	if (r1 == 1) ba(1:2,2,1:2) = 0.0d0

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Compute crustal thickness by iterating at each
	!	reference moho depth. Gravity anomalies are calculated
	!	using n*lmax coefficients, but only the first lmax are
	!	used in the crustal thickness calculations.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	d = r0 - 44.0d3		! initial reference moho depth

	thick_delta = 1.d9

	do while (abs(thick_delta) > delta_max)

		write(*,*)
		print*, "Reference depth (km) = ", (r0-d)/1.d3

		moho_c(1,1,1) = d

		! first iteration
		do l=1, degmax
			if (filter_type == 0) then
				moho_c(1:2,l+1,1:l+1) = ba(1:2,l+1,1:l+1) * mass * dble(2*l+1) * ((r0/d)**l) &
				/(4.0d0*pi*(rho_mantle-rho_crust)*d**2)
			elseif (filter_type == 1) then
				moho_c(1:2,l+1,1:l+1) = downcontfilterma(l, half, r0, d) * ba(1:2,l+1,1:l+1) * mass * dble(2*l+1) * ((r0/d)**l) &
				/(4.0d0*pi*(rho_mantle-rho_crust)*d**2)
			elseif (filter_type == 2) then
				moho_c(1:2,l+1,1:l+1) = downcontfiltermc(l, half, r0, d) * ba(1:2,l+1,1:l+1) * mass * dble(2*l+1) * ((r0/d)**l) &
				/(4.0d0*pi*(rho_mantle-rho_crust)*d**2)
			endif
		enddo

		call MakeGridDH(moho_grid3, n_out, moho_c, lmax, norm = 1, sampling = sampling, csphase = 1, lmax_calc = degmax)

		max_thick = maxval(topo_grid(1:nlat, 1:nlong)-moho_grid3(1:nlat, 1:nlong))
		min_thick = minval(topo_grid(1:nlat, 1:nlong)-moho_grid3(1:nlat, 1:nlong))
		print*, "Maximum Crustal thickness (km) = ", max_thick/1.d3
		print*, "Minimum Crustal thickness (km) = ", min_thick/1.d3

		! second iteration
		if (filter_type == 0) then
			call BAtoHilm(moho_c, ba, moho_grid3, lmax, nmax, mass, r0, rho_mantle-rho_crust, gridtype, &
				lmax_calc = degmax)
		else
			call BAtoHilm(moho_c, ba, moho_grid3, lmax, nmax, mass, r0, rho_mantle-rho_crust, gridtype, &
				filter_type=filter_type, filter_deg=half, lmax_calc = degmax)
		endif
		call MakeGridDH(moho_grid2, n_out, moho_c, lmax, norm = 1, sampling = sampling, csphase = 1, lmax_calc = degmax)

		delta = maxval(abs(moho_grid3(1:nlat, 1:nlong)-moho_grid2(1:nlat, 1:nlong)))
		print*, "Delta (km) = ", delta/1.d3

		temp_grid(1:nlat, 1:nlong) = topo_grid(1:nlat, 1:nlong)-moho_grid2(1:nlat, 1:nlong)
		max_thick = maxval(temp_grid(1:nlat, 1:nlong))
		min_thick = minval(temp_grid(1:nlat, 1:nlong))
		print*, "Maximum Crustal thickness (km) = ", max_thick/1.d3
		print*, "Minimum Crustal thickness (km) = ", min_thick/1.d3

		iter = 0
		delta = 1.0d9

		do while(delta > delta_max)

			iter = iter + 1
			print*, "Iteration ", iter

			moho_grid(1:nlat,1:nlong) = (moho_grid2(1:nlat,1:nlong) + moho_grid3(1:nlat,1:nlong)) / 2.0d0

			delta = maxval(abs(moho_grid(1:nlat, 1:nlong)-moho_grid2(1:nlat, 1:nlong)))
			print*, "Delta (km) = ", delta/1.d3

			temp_grid(1:nlat, 1:nlong) = topo_grid(1:nlat, 1:nlong)-moho_grid(1:nlat, 1:nlong)
			max_thick = maxval(temp_grid(1:nlat, 1:nlong))
			min_thick = minval(temp_grid(1:nlat, 1:nlong))
			print*, "Maximum Crustal thickness (km) = ", max_thick/1.d3
			print*, "Minimum Crustal thickness (km) = ", min_thick/1.d3

			moho_grid3(1:nlat, 1:nlong) = moho_grid2(1:nlat, 1:nlong)
			moho_grid2(1:nlat, 1:nlong) = moho_grid(1:nlat, 1:nlong)

			iter = iter +1
			print*, "Iteration ", iter

			if (filter_type == 0) then
				call BAtoHilm(moho_c, ba, moho_grid2, lmax, nmax, mass, r0, rho_mantle-rho_crust, gridtype, &
					lmax_calc = degmax)
			else
				call BAtoHilm(moho_c, ba, moho_grid2, lmax, nmax, mass, r0, rho_mantle-rho_crust, gridtype, &
					filter_type=filter_type, filter_deg=half, lmax_calc = degmax)
			endif
			call MakeGridDH(moho_grid, n_out, moho_c, lmax, norm = 1, sampling = sampling, csphase = 1, lmax_calc = degmax)

			delta = maxval(abs(moho_grid(1:nlat, 1:nlong)-moho_grid2(1:nlat, 1:nlong)))
			print*, "Delta (km) = ", delta/1.d3

			temp_grid(1:nlat, 1:nlong) = topo_grid(1:nlat, 1:nlong)-moho_grid(1:nlat, 1:nlong)
			max_thick = maxval(temp_grid(1:nlat, 1:nlong))
			min_thick = minval(temp_grid(1:nlat, 1:nlong))
			print*, "Maximum Crustal thickness (km) = ", max_thick/1.d3
			print*, "Minimum Crustal thickness (km) = ", min_thick/1.d3

			moho_grid3(1:nlat, 1:nlong) = moho_grid2(1:nlat, 1:nlong)
			moho_grid2(1:nlat, 1:nlong) = moho_grid(1:nlat, 1:nlong)

			if (max_thick > 100.d3) then
				print*, "Not converging"
				stop
			endif

		enddo

		d = d + (min_thick-t0)
		thick_delta  = min_thick  - t0

	enddo

	thinnest(1:2) = minloc(temp_grid(1:nlat, 1:nlong))
	if (gridtype == 2) then
		print*, "Location of thinnest crust (lat, long) = ", &
			90.0d0 - dble((thinnest(1) - 1))*180.0/dble(nlat), dble(thinnest(2)-1)*360.0/dble(nlat)
	elseif(gridtype == 3) then
		print*, "Location of thinnest crust (lat, long) = ", &
			90.0d0 - dble((thinnest(1) - 1))*180.0/dble(nlat), dble(thinnest(2)-1)*180.0/dble(nlat)
	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Determine misfit between observed and calculated gravity, and write
	!	data to external files. Note that here, only coefficients up to lmax
	!	are considered.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	call CilmPlus(cilm, moho_grid, degmax, nmax, mass, rref, rho_mantle-rho_crust, gridtype, n=nlat)

	! upward continue moho coefficients
	do l=0, degmax
		cilm(1:2,l+1,1:l+1) = cilm(1:2,l+1,1:l+1) * (d/r0)**l
	enddo

	misfit = pot - (bc + cilm) 	! this is the misfit
	misfit(1,1,1) = 0.0d0		! ignore degree-0 misfit

	do l=0, degmax
		cilm(1:2,l+1,1:l+1) = misfit(1:2,l+1,1:l+1)*dble(l+1.0d0)*gm*(1.0d5)/r0**2
	enddo

	call MakeGridDH(temp_grid, n_out, cilm, lmax, norm = 1, sampling = sampling, csphase = 1, lmax_calc = degmax)

	print*, "Maximum misfit (mgals) = ", maxval(temp_grid(1:nlat, 1:nlong))
	print*, "Minimum misfit (mgals) = ", minval(temp_grid(1:nlat, 1:nlong))

	print*, "Mean Crustal Thickness (km) =", (r0-moho_c(1,1,1))/1.d3

	print*, "Writing output data"

	open(12,file=moho_out)

	do l=0,degmax
		do m=0,l
			write(12,*) l, m, moho_c(1,l+1,m+1), moho_c(2,l+1,m+1)
		enddo
	enddo

	close(12)

	call MakeGrid2d(topo_grid, topo_c - moho_c, degmax, interval, nlat, nlong)

	open(12, file=thick_grid_out)
	write(12,*) nlat, nlong
	do i=1, nlat
		do j=1,nlong
			write(12,*) topo_grid(i,j)/1.d3
		enddo
	enddo

	close(12)

	open(12, file=misfit_file)
	do l=0,degmax
		do m=0,l
			write(12,*) l, m, misfit(1,l+1,m+1), misfit(2,l+1,m+1)
		enddo
	enddo

	close(12)

	deallocate(topo_grid)
	deallocate(moho_grid)
	deallocate(moho_grid2)
	deallocate(moho_grid3)
	deallocate(temp_grid)
	deallocate(topo_c)
	deallocate(moho_c)
	deallocate(bc)
	deallocate(ba)
	deallocate(cilm)
	deallocate(pot)
	deallocate(misfit)

	call cpu_time(timeout)
	print*, "time (sec) = ", timeout-timein

end program MarsCrustalThickness


C
C $Id: nggcog.f,v 1.4 2008-07-27 00:17:17 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
C This is a modified version of nggcog.f that was generated using
C nag_apt to convert from single to double precision.
C
      SUBROUTINE DNGGCOG (CLAT,CLON,CRAD,ALAT,ALON,NPTS)
      DOUBLE PRECISION CLAT
      DOUBLE PRECISION CLON
      DOUBLE PRECISION CRAD
      DOUBLE PRECISION ALAT
      DOUBLE PRECISION ALON
      DOUBLE PRECISION DTOR
      DOUBLE PRECISION RTOD
      DOUBLE PRECISION RLAT
      DOUBLE PRECISION RLON
      DOUBLE PRECISION UCRD
      DOUBLE PRECISION VCRD
      DOUBLE PRECISION WCRD
C
C This routine returns, in the arrays ALAT and ALON, the latitudes and
C longitudes of NPTS points on the surface of the globe, all of them at
C the great-circle distance CRAD from the point (CLAT,CLON), defining a
C circle.  The last point returned is a copy of the first.
C
        DIMENSION ALAT(*),ALON(*)
C
C Define multiplicative constants to convert from degrees to radians
C and from radians to degrees.
C
        DATA DTOR / .017453292519943D0 /
        DATA RTOD / 57.2957795130823D0 /
C
C Points on a circle around the North Pole are rotated to lie around
C the point at latitude CLAT and longitude CLON.
C
        RLAT=DTOR*(90.D0-CRAD)
C
        DO 101 IPNT=1,NPTS
          RLON=DTOR*360.D0*(DBLE(IPNT-1)/DBLE(NPTS-1))
          UCRD=COS(RLAT)*COS(RLON)
          VCRD=COS(RLAT)*SIN(RLON)
          WCRD=SIN(RLAT)
          CALL DNGRITD (2,90.D0-CLAT,UCRD,VCRD,WCRD)
          CALL DNGRITD (3,      CLON,UCRD,VCRD,WCRD)
          ALAT(IPNT)=RTOD*ASIN(WCRD)
          ALON(IPNT)=RTOD*ATAN2(VCRD,UCRD)
  101   CONTINUE
C
C Done.
C
        RETURN
C
      END


MODULE module_sf_sfcdiags_ruclsm

CONTAINS

   SUBROUTINE SFCDIAGS_RUCLSM(HFX,QFX,TSK,QSFC,CHS2,CQS2,T2,TH2,Q2, &
                     T3D,QV3D,RHO3D,P3D, &
                     PSFC,CP,R_d,ROVCP, &
                     ids,ide, jds,jde, kds,kde, &
                     ims,ime, jms,jme, kms,kme, &
                     its,ite, jts,jte, kts,kte )

      IMPLICIT NONE

      INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
                                        ims,ime, jms,jme, kms,kme, &
                                        its,ite, jts,jte, kts,kte
      REAL, DIMENSION( ims:ime, jms:jme ) , &
                INTENT(IN) :: HFX, &
                                                              QFX, &
                                                              TSK, &
                                                             QSFC
      REAL, DIMENSION( ims:ime, jms:jme ) , &
                INTENT(INOUT) :: Q2, &
                                                              TH2, &
                                                              T2
      REAL, DIMENSION( ims:ime, jms:jme ) , &
                INTENT(IN) :: PSFC, &
                                                             CHS2, &
                                                             CQS2
      REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
               INTENT(IN ) :: QV3D, &
                                                              T3D, &
                                                              P3D, &
                                                            rho3D

      REAL, INTENT(IN ) :: CP,R_d,ROVCP

      INTEGER :: I,J
      REAL :: RHO, x2m, qlev1, tempc, qsat, p2m

      DO J=jts,jte
        DO I=its,ite

          RHO = RHO3D(i,1,j)
          P2m = PSFC(I,J)*EXP(-0.068283/t3d(i,1,j))

          if(CHS2(I,J).lt.1.E-5) then

             TH2(I,J) = t3d(i,1,j)*(1.E5/P2m)**ROVCP
          else
             TH2(I,J) = TSK(I,J)*(1.E5/PSFC(I,J))**ROVCP - HFX(I,J)/(RHO*CP*CHS2(I,J))

          endif

             T2(I,J) = TH2(I,J)*(1.E-5*P2m)**ROVCP

             x2m = MAX(MIN(tsk(i,j),t3d(i,1,j)) , t2(i,j))
             t2(i,j) = MIN(MAX(tsk(i,j),t3d(i,1,j)) , x2m)

             TH2(I,J) = T2(I,J)*(1.E5/P2m)**ROVCP

             qlev1 = qv3d(i,1,j)

             tempc=t3d(i,1,j)-273.15
           if (tempc .le. 0.0) then

             qsat = rsif(p3d(i,1,j), t3d(i,1,j))
           else
             qsat = rslf(p3d(i,1,j), t3d(i,1,j))
           endif
             qlev1 = min(qsat, qlev1)

          if(CQS2(I,J).lt.1.E-5) then

             Q2(I,J)=qlev1
          else
             x2m = QSFC(I,J) - QFX(I,J)/(RHO*CQS2(I,J))
             Q2(I,J)=x2m/(1.-x2m)
          endif

             x2m = MAX(MIN(qsfc(i,j)/(1.-qsfc(i,j)),qlev1) , q2(i,j))
             q2(i,j) = MIN(MAX(qsfc(i,j)/(1.-qsfc(i,j)),qlev1) , x2m)

             tempc=t2(i,j)-273.15
           if (tempc .le. 0.0) then

             qsat = rsif(psfc(i,j), t2(i,j))
           else
             qsat = rslf(psfc(i,j), t2(i,j))
           endif

             q2(i,j) = min(qsat, q2(i,j))

        ENDDO
      ENDDO

  END SUBROUTINE SFCDIAGS_RUCLSM

      REAL FUNCTION RSLF(P,T)

      IMPLICIT NONE
      REAL, INTENT(IN):: P, T
      REAL:: ESL,X
      REAL, PARAMETER:: C0= .611583699E03
      REAL, PARAMETER:: C1= .444606896E02
      REAL, PARAMETER:: C2= .143177157E01
      REAL, PARAMETER:: C3= .264224321E-1
      REAL, PARAMETER:: C4= .299291081E-3
      REAL, PARAMETER:: C5= .203154182E-5
      REAL, PARAMETER:: C6= .702620698E-8
      REAL, PARAMETER:: C7= .379534310E-11
      REAL, PARAMETER:: C8=-.321582393E-13

      X=MAX(-80.,T-273.16)

      ESL=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8)))))))
      RSLF=.622*ESL/(P-ESL)

      END FUNCTION RSLF
      REAL FUNCTION RSIF(P,T)
      IMPLICIT NONE
      REAL, INTENT(IN):: P, T
      REAL:: ESI,X
      REAL, PARAMETER:: C0= .609868993E03
      REAL, PARAMETER:: C1= .499320233E02
      REAL, PARAMETER:: C2= .184672631E01
      REAL, PARAMETER:: C3= .402737184E-1
      REAL, PARAMETER:: C4= .565392987E-3
      REAL, PARAMETER:: C5= .521693933E-5
      REAL, PARAMETER:: C6= .307839583E-7
      REAL, PARAMETER:: C7= .105785160E-9
      REAL, PARAMETER:: C8= .161444444E-12
      X=MAX(-80.,T-273.16)
      ESI=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8)))))))
      RSIF=.622*ESI/(P-ESI)
      END FUNCTION RSIF
END MODULE module_sf_sfcdiags_ruclsm


!
!    --------------------------------------------------------------
!         H L C
!    --------------------------------------------------------------
!
      DOUBLE PRECISION FUNCTION HLC (EL, I, J, REL)
      use param_C
      use radial_C
      use nel_C, EL_=>EL
!
! *** COMPUTES HL(I,J) MODIFIED BY THE INTERACTIONS WITH THE CLOSED
!     SHELL
!
!
! *** COMPUTES HL(I,J) MODIFIED BY THE INTERACTIONS WITH THE CLOSED
!     SHELL
!
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
!...Translated by Pacific-Sierra Research 77to90  4.3E  00:39:53  11/16/01
!...Switches:
!      PARAMETER(NOD=220)
!      COMMON/PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MSOO,NCFG,IB,IC,ID
!     :   ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS
!      COMMON/RADIAL/R(NOD),RR(NOD),R2(NOD),YK(NOD),YR(NOD),X(NOD)
!      POINTER(IQP,P(NOD,1)),(IQN,N(1)),(IQL,L(1)),(IQAZ,AZ(1)),
!     :       (IQMAX,MAX_(1))
!      COMMON/NEL/IQP,IQN,IQL,IQAZ,IQMAX,IQ(7)
!
      CHARACTER*1 :: EL(*)*3
      LOGICAL :: REL
      HLC = HL(EL,I,J,REL)
!
      LI = L(I)
      DO IP = 1, NCLOSD
         LP = L(IP)
         SUMIP = 4*LP + 2
         T = RK(I,IP,J,IP,0,REL)                 ! direct interaction
         K1 = IABS(LI - LP)
         K2 = LI + LP
         DO K = K1, K2, 2
            CB = ZCB(LI,K,LP)/2
!                                            ! exchange interaction
            T = T - CB*RK(I,IP,IP,J,K,REL)
!                                            ! o-o - interaction
            IF (MSOO.GT.2 .AND. LI.GT.0 .AND. LP.GT.0) THEN
               CN = CB*(LI + LP + K + 2)*(LI + LP - K)*(LI - LP + K + 1)*(LP - &
                  LI + K + 1)
               CN = CN/((K + 1)*(K + 2))
               IF (ABS(CN) .GT. 0.0) T = T + CN*(SN(I,IP,IP,J,K) + SN(IP,I,J,IP&
                  ,K))
            ENDIF
!
         END DO
!
         HLC = HLC - 2*SUMIP*T
!
      END DO
      RETURN
      END FUNCTION HLC


C    %W% %G%
      subroutine rmargn(bus1,base1,bus2,base2,ipar,lin6)
C * * *
C * * * THIS SUBROUTINE CALCULATES THE DISTANCE BETWEEN THE
C * * * TRIPPING LINE AND THE R AND RDOT OF A LINE.  THIS
C * * * DISTANCE IS KNOWN AS THE MARGIN.  BUS1,BASE1,BUS2,
C * * * BASE2,IPAR IDENTIFY THE LINE BEING PROCESSED.  LIN6
C * * * IS THE STARTING ADDRESS FOR R AND RDOT IN THE TABLE
C * * * WORKSP.  RMARGN IS CALLED BY LINOUT.
C * * *
      include 'tspinc/params.inc'
      include 'tspinc/room.inc'
      include 'tspinc/comn56.inc'
      include 'tspinc/prt.inc'
      include 'tspinc/rddat.inc'
      include 'tspinc/worst.inc'
      dimension rmar(2000)
      character*8 bus1,bus2
      character*1 ipar
      if(irdknt .eq. 0)return
      do 200 ltrr = 1,irdknt
      if(rname1(ltrr) .ne. bus1 .or. rname2(ltrr) .ne. bus2) go to 200
      if(rbkv1(ltrr) .ne. base1 .or. rbkv2(ltrr) .ne. base2) go to 200
      if(rpar(ltrr) .eq. ipar) go to 300
 200  continue
      return
C * * *
C * * * CALCULATE THE INTERCEPT FOR THE TRIP LINE--B1
C * * * THE TRIP LINE EQUATION IS Y = SLOPE1*X + B1
C * * *
 300  slope1 = rslope(ltrr)
      x0 = rzero(ltrr)
      b1 = -slope1*x0
C * * *
C * * * SLOPE2 IS THE SLOPE OF A LINE PERPENDICULAR TO
C * * * THE TRIP LINE
C * * *
      slope2 = -1.0/slope1
      rrdmax(ltrr) = -10000.
      rrdmin(ltrr) = 10000.
      ktrr = 0
      rtmax(ltrr) = 0.0
      rtmin(ltrr) = 0.0
      icnt2 = 2*icount
      do 400 jtrr = 1,icnt2,2
      ktrr = ktrr+1
      r = worksp(lin6+jtrr)
      rdot = worksp(lin6 +jtrr+1)
C * * *
C * * * IF RDOT IS POSITIVE, SET MARGIN TO A LARGE NUMBER AND
C * * * GO TO THE NEXT POINT.  TRIP LINE IS DEFINED ONLY FOR
C * * * NEGATIVE VALUES OF RDOT
C * * *
      if(rdot .gt. 0.0)then
        rmar(ktrr) = 1000.
        go to 400
      endif
C * * *
C * * * THE EQUATION OF A LINE PERPENDICULAR TO THE TRIP
C * * * LINE WHICH PASSES THROUGH THE POINT (R,RDOT) IS
C * * * RDOT = SLOPE2*R + B2.  THIS IS THE SHORTEST
C * * * DISTANCE BETWEEN THE TRIP LINE AND THE POINT (R,RDOT)
C * * *
      b2 = rdot - slope2*r
C * * *
C * * * FIND THE POINT (R1,RDOT1) WHICH IS THE INTERSECTION
C * * * OF THE TRIP LINE AND THE SHORTEST DISTANCE LINE.
C * * * IT SATISFIES BOTH RDOT1 = SLOPE1*R1 + B1 AND
C * * * RDOT1 = SLOPE2*R1 + B2. SO SLOPE1*R1 + B1 = SLOPE2*R1 + B2
C * * *
      r1 = (b2-b1)/(slope1-slope2)
C * * *
C * * * THE MARGIN IS THE DIFFERENCE BETWEEN R1 AND R
C * * *
      rmar(ktrr) = r - r1
      if(wtim2 .ne. -1)then
         indx = (jtrr+1)/2
         tnow = t(indx)
         if(tnow .gt. wtim1 .and. tnow .lt. wtim2)then
            if(rmar(ktrr) .gt. rrdmax(ltrr))then
               rrdmax(ltrr) = rmar(ktrr)
               rtmax(ltrr) = t(ktrr)
            endif
            if(rmar(ktrr) .lt. rrdmin(ltrr))then
               rrdmin(ltrr) = rmar(ktrr)
               rtmin(ltrr) = t(ktrr)
            endif
         endif
      else
         if(rmar(ktrr) .gt. rrdmax(ltrr))then
            rrdmax(ltrr) = rmar(ktrr)
            rtmax(ltrr) = t(ktrr)
         endif
         if(rmar(ktrr) .lt. rrdmin(ltrr))then
            rrdmin(ltrr) = rmar(ktrr)
            rtmin(ltrr) = t(ktrr)
         endif
      endif
 400  continue
      write(outbuf,500)
 500  format('0',5x,' TRIPPING MARGIN IN OHMS ')
      call prtout(1)
      if(wtim2 .ne. -1)then
         write(outbuf,550)wtim1,wtim2
  550    format(5x,'DURING TIME WINDOW ',f8.2,' CYCLES TO ',f8.2,
     1          ' CYCLES.')
         call prtout(1)
      endif
      write(outbuf,600)rrdmax(ltrr),rtmax(ltrr),rrdmin(ltrr),rtmin(ltrr)
 600  format('0',5x,' MAXIMUM MARGIN =',f8.2,' AT ',f8.2,' CYCLES. ',
     1       ' MINIMUM MARGIN = ',f8.2,' AT ',f8.2,' CYCLES. ')
      call prtout(1)
      do 800 jjj=1,icount,5
      kkk = min0(jjj+4,icount)
      write(outbuf,700) (t(jj),rmar(jj),jj=jjj,kkk)
 700  format(5(1x,f8.2,'CYCLES',f9.2))
      call prtout(1)
 800  continue
      return
      end


      subroutine qlbox9(Y,musq,Ires)
      implicit none
c  $I^{\{D=4-2 \epsilon\}}_4(0,p_2^2,p_3^2,m^2;s_{12},s_{23};0,0,0,m^2)$}

c                    [                       s12                ]
c                    [   0        0        - ---         0      ]
c                    [                        2                 ]
c                    [                                          ]
c                    [                       p2sq    msq - s23  ]
c                    [   0        0        - ----    ---------  ]
c                    [                        2          2      ]
c               y9 = [                                          ]
c                    [   s12     p2sq                msq - p3sq ]
c                    [ - ---   - ----        0       ---------- ]
c                    [    2       2                      2      ]
c                    [                                          ]
c                    [        msq - s23  msq - p3sq             ]
c                    [   0    ---------  ----------     msq     ]
c                    [            2          2                  ]
      include 'qlconstants.f'
      integer iep
      double complex Ires(-2:0),qllnrat,wlogt,wlog2,
     . dilog1,dilog2,qlLi2omrat,qlLi2omx2
      double precision Y(4,4),msq,musq,tabar,si,fac,mean,m3sqbar,mp2sq

      msq=Y(4,4)
      mean=sqrt(musq*msq)
      tabar=2d0*Y(2,4)
      si=2d0*Y(1,3)
      m3sqbar=2d0*Y(3,4)
      mp2sq=2d0*Y(2,3)
      fac=si*tabar

      wlogt=qllnrat(tabar,mean)
      wlog2=qllnrat(si,mp2sq)

      dilog1=qlLi2omx2(m3sqbar,tabar,mp2sq,msq)
      dilog2=qlLi2omrat(si,mp2sq)
      Ires(-2)=dcmplx(0.5d0)
      Ires(-1)=-wlogt-wlog2
      Ires( 0)=dilog1+2d0*dilog2+dcmplx(pisq/12d0)+(wlogt+wlog2)**2
      do iep=-2,0
      Ires(iep)=Ires(iep)/dcmplx(fac)
      enddo
      return
      end


!   ********************************************************************
!   *                                                                  *
!   *                       function ntwom                             *
!   *                                                                  *
!   ********************************************************************
!   Integer Version 1.0
!   Written by G. A. Fenton, Princeton, June 7, 1988.
!
!   PURPOSE  return M such that a given N = 2**M
!
!   Returns the power that two must be raised to to get the value of the
!   argument, or in other words, returns m such that
!
!        N = 2**m
!
!   where N is the input argument integer and N > 0. If N is not a power
!   of 2, then the next smaller power is returned. The maximum power
!   returned is 40.
!-------------------------------------------------------------------------
      integer function ntwom( N )
      integer N, k

      k = 1
      do 20 ntwom = 0, 40
         if( N .le. k ) go to 30
         k = 2*k
  20  continue

  30  if( N .lt. k ) ntwom = ntwom - 1

      return
      end


! RUN: bbc -emit-fir -outline-intrinsics %s -o - | FileCheck %s

! Test statement function lowering

! Simple case
  ! CHECK-LABEL: func @_QPtest_stmt_0(
  ! CHECK-SAME: %{{.*}}: !fir.ref<f32>{{.*}}) -> f32
real function test_stmt_0(x)
  real :: x, func, arg
  func(arg) = arg + 0.123456

  ! CHECK-DAG: %[[x:.*]] = fir.load %arg0
  ! CHECK-DAG: %[[cst:.*]] = arith.constant 1.234560e-01
  ! CHECK: %[[eval:.*]] = arith.addf %[[x]], %[[cst]]
  ! CHECK: fir.store %[[eval]] to %[[resmem:.*]] : !fir.ref<f32>
  test_stmt_0 = func(x)

  ! CHECK: %[[res:.*]] = fir.load %[[resmem]]
  ! CHECK: return %[[res]]
end function

! Check this is not lowered as a simple macro: e.g. argument is only
! evaluated once even if it appears in several placed inside the
! statement function expression
! CHECK-LABEL: func @_QPtest_stmt_only_eval_arg_once() -> f32
real(4) function test_stmt_only_eval_arg_once()
  real(4) :: only_once, x1
  func(x1) = x1 + x1
  ! CHECK: %[[x2:.*]] = fir.alloca f32 {adapt.valuebyref}
  ! CHECK: %[[x1:.*]] = fir.call @_QPonly_once()
  ! Note: using -emit-fir, so the faked pass-by-reference is exposed
  ! CHECK: fir.store %[[x1]] to %[[x2]]
  ! CHECK: addf %{{.*}}, %{{.*}}
  test_stmt_only_eval_arg_once = func(only_once())
end function

! Test nested statement function (note that they cannot be recursively
! nested as per F2018 C1577).
real function test_stmt_1(x, a)
  real :: y, a, b, foo
  real :: func1, arg1, func2, arg2
  real :: res1, res2
  func1(arg1) = a + foo(arg1)
  func2(arg2) = func1(arg2) + b
  ! CHECK-DAG: %[[bmem:.*]] = fir.alloca f32 {{{.*}}uniq_name = "{{.*}}Eb"}
  ! CHECK-DAG: %[[res1:.*]] = fir.alloca f32 {{{.*}}uniq_name = "{{.*}}Eres1"}
  ! CHECK-DAG: %[[res2:.*]] = fir.alloca f32 {{{.*}}uniq_name = "{{.*}}Eres2"}

  b = 5

  ! CHECK-DAG: %[[cst_8:.*]] = arith.constant 8.000000e+00
  ! CHECK-DAG: fir.store %[[cst_8]] to %[[tmp1:.*]] : !fir.ref<f32>
  ! CHECK-DAG: %[[foocall1:.*]] = fir.call @_QPfoo(%[[tmp1]])
  ! CHECK-DAG: %[[aload1:.*]] = fir.load %arg1
  ! CHECK: %[[add1:.*]] = arith.addf %[[aload1]], %[[foocall1]]
  ! CHECK: fir.store %[[add1]] to %[[res1]]
  res1 =  func1(8.)

  ! CHECK-DAG: %[[a2:.*]] = fir.load %arg1
  ! CHECK-DAG: %[[foocall2:.*]] = fir.call @_QPfoo(%arg0)
  ! CHECK-DAG: %[[add2:.*]] = arith.addf %[[a2]], %[[foocall2]]
  ! CHECK-DAG: %[[b:.*]] = fir.load %[[bmem]]
  ! CHECK: %[[add3:.*]] = arith.addf %[[add2]], %[[b]]
  ! CHECK: fir.store %[[add3]] to %[[res2]]
  res2 = func2(x)

  ! CHECK-DAG: %[[res12:.*]] = fir.load %[[res1]]
  ! CHECK-DAG: %[[res22:.*]] = fir.load %[[res2]]
  ! CHECK: = arith.addf %[[res12]], %[[res22]] : f32
  test_stmt_1 = res1 + res2
  ! CHECK: return %{{.*}} : f32
end function

! Test statement functions with no argument.
! Test that they are not pre-evaluated.
! CHECK-LABEL: func @_QPtest_stmt_no_args
real function test_stmt_no_args(x, y)
  func() = x + y
  ! CHECK: addf
  a = func()
  ! CHECK: fir.call @_QPfoo_may_modify_xy
  call foo_may_modify_xy(x, y)
  ! CHECK: addf
  ! CHECK: addf
  test_stmt_no_args = func() + a
end function

! Test statement function with character arguments
! CHECK-LABEL: @_QPtest_stmt_character
integer function test_stmt_character(c, j)
  integer :: i, j, func, argj
  character(10) :: c, argc
  ! CHECK-DAG: %[[unboxed:.*]]:2 = fir.unboxchar %arg0 :
  ! CHECK-DAG: %[[c10:.*]] = arith.constant 10 :
  ! CHECK: %[[c10_cast:.*]] = fir.convert %[[c10]] : (i32) -> index
  ! CHECK: %[[c:.*]] = fir.emboxchar %[[unboxed]]#0, %[[c10_cast]]

  func(argc, argj) = len_trim(argc, 4) + argj
  ! CHECK: addi %{{.*}}, %{{.*}} : i
  test_stmt_character = func(c, j)
end function

! Test statement function with a character actual argument whose
! length may be different than the dummy length (the dummy length
! must be used inside the statement function).
! CHECK-LABEL: @_QPtest_stmt_character_with_different_length(
! CHECK-SAME: %[[arg0:.*]]: !fir.boxchar<1>
integer function test_stmt_character_with_different_length(c)
  integer :: func, ifoo
  character(10) :: argc
  character(*) :: c
  ! CHECK-DAG: %[[unboxed:.*]]:2 = fir.unboxchar %[[arg0]] :
  ! CHECK-DAG: %[[c10:.*]] = arith.constant 10 :
  ! CHECK: %[[c10_cast:.*]] = fir.convert %[[c10]] : (i32) -> index
  ! CHECK: %[[argc:.*]] = fir.emboxchar %[[unboxed]]#0, %[[c10_cast]]
  ! CHECK: fir.call @_QPifoo(%[[argc]]) : (!fir.boxchar<1>) -> i32
  func(argc) = ifoo(argc)
  test_stmt_character = func(c)
end function

! CHECK-LABEL: @_QPtest_stmt_character_with_different_length_2(
! CHECK-SAME: %[[arg0:.*]]: !fir.boxchar<1>{{.*}}, %[[arg1:.*]]: !fir.ref<i32>
integer function test_stmt_character_with_different_length_2(c, n)
  integer :: func, ifoo
  character(n) :: argc
  character(*) :: c
  ! CHECK: %[[unboxed:.*]]:2 = fir.unboxchar %[[arg0]] :
  ! CHECK: fir.load %[[arg1]] : !fir.ref<i32>
  ! CHECK: %[[n:.*]] = fir.load %[[arg1]] : !fir.ref<i32>
  ! CHECK: %[[n_is_positive:.*]] = arith.cmpi sgt, %[[n]], %c0{{.*}} : i32
  ! CHECK: %[[len:.*]] = arith.select %[[n_is_positive]], %[[n]], %c0{{.*}} : i32
  ! CHECK: %[[lenCast:.*]] = fir.convert %[[len]] : (i32) -> index
  ! CHECK: %[[argc:.*]] = fir.emboxchar %[[unboxed]]#0, %[[lenCast]] : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
  ! CHECK: fir.call @_QPifoo(%[[argc]]) : (!fir.boxchar<1>) -> i32
  func(argc) = ifoo(argc)
  test_stmt_character = func(c)
end function

! issue #247
! CHECK-LABEL: @_QPbug247
subroutine bug247(r)
  I(R) = R
  ! CHECK: fir.call {{.*}}OutputInteger
  PRINT *, I(2.5)
  ! CHECK: fir.call {{.*}}EndIo
END subroutine bug247


      SUBROUTINE ATTMX1(KEY,ZRA,ZDEC,CLOCK,MATRIX)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  THIS ROUTINE COMPUTES THE MATRIX USED ROTATE A VECTOR BETWEEN
C  THE ORBITER BODY AXIS SYSTEM AND ANOTHER SYSTEM TO WHICH THE ORBITER
C  BODY AXES ARE REFERENCED.
C  IT DOES THIS BY COMPUTING THE TRANSFORMATION FOR:
C            (1)  YAW  BY (ZRA+(PI/2))  RADIANS
C            (2)  ROLL BY ((PI/2)-ZDEC) RADIANS
C            (3)  YAW  BY (CLOCK)       RADIANS
C
C  THE ORBITER BODY AXES ARE: X IS THE ROLL AXIS. +X TO NOSE.
C                             Y IS PITCH AXIS. +Y IS OUT THE STARBOARD
C                               WING.
C                             Z IS YAW AXIS. -Z IS UP FROM THE BAY.
C
C*********************************************************************
C
C  VARIABLES  DIM  TYPE   I/O   DESCRIPTION
C  ---------  ---  ----   ---   -----------
C
C  KEY        1    I*4     I    FLAG INDICATING COORD SYSTEMS FROM AND
C                               TO WHICH ROTATIONS WILL BE DONE USING
C                               THE MATRIX COMPUTED HERE.
C
C                               = +: VEC(BODY) = MATRIX * VEC(REFERENCE)
C                                    I.E.- ROTATING TO BODY COORDINATES.
C                               = -: VEC(REFERENCE) = MATRIX * VEC(BODY)
C                                    I.E.- ROTATING TO REF COORDINATES.
C
C                               THE REFERENCE SYSTEM IS THE ONE TO WHICH
C                               THE ORBITER +Z AXIS(DOWN) AND +X(NOSE)
C                               AXES ARE REFERENCED.
C                               THE REFERENCE SYSTEM CAN BE ANYTHING,
C                               BUT IS TYPICALLY INERTIAL OR LOCAL
C                               ORBITAL.
C
C  ZRA        1    R*8     I    THE RIGHT ASCENSION OF THE ORBITER +Z
C                               AXIS RELATIVE TO THE REFERENCE SYSTEM.
C                               IF THE DECLINATION(ZDEC) IS +/- PI/2,
C                               THEN ANY ZRA MAY BE USED SINCE ALL WILL
C                               PRODUCE THE SAME RESULT.
C                               RADIANS.
C
C  ZDEC       1    R*8     I    THE DECLINATION OF THE ORBITER +Z AXIS
C                               RELATIVE TO THE REFERENCE SYSTEM.
C                               RADIANS.
C
C  CLOCK      1    R*8     I    NOSE CLOCK ANGLE. RADIANS.
C                               FOR 0.0 ANGLE, THE ORBITER NOSE IS
C                               POINTED ALONG THE VECTOR PRODUCT
C                               (REFERENCE +Z AXIS) X (ORBITER +Z AXIS).
C
C                               IF ZDEC IS -PI/2, THEN CLOCK=0.0 PLACES
C                               THE ORBITER +X AXIS ALONG THE REFERENCE
C                               -X AXIS.
C                               IF ZDEC IS +PI/2, THEN CLOCK=0.0 PLACES
C                               THE ORBITER +X AXIS ALONG THE REFERENCE
C                               +X AXIS.
C
C                               CLOCK ANGLE IS THE ANGLE THROUGH WHICH
C                               THE ORBITER NOSE HAS BEEN ROTATED ABOUT
C                               ITS Z-AXIS FROM THE 0.0 POSITION.
C                               ROTATION IS FROM THE NOSE TOWARD THE
C                               RIGHT WING.
C
C  MATRIX     3,3  R*8     O    ROTATION MATRIX.
C                               ROTATES FROM VECTOR V1 TO VECTOR V2 :
C                               V2(I) = MATRIX(I,J)*V1(J), SUMMING ON J.
C
C**********************************************************************
C
C
C   CODED BY CHARLIE PETRUZZ0.  6/81.
C    MODIFIED.............
C        CJP 2/82. ADDED MODS TO HANDLE ZDEC=+/-PI/2. ALL ZRA NOW GIVE
C                  SAME MATRIX. COMMENTS CHANGED IN ZRA AND CLOCK
C                  DESCRIPTIONS ABOVE.
C
C
C
C
      REAL*8 MATRIX(3,3),A(3,3)
      REAL*8 TWOPI/ 6.283185307179586D0 /
      REAL*8 DECTEST/0.999999999999D0/
C
      ZCOSD=DCOS(ZDEC)
      ZSIND=DSIN(ZDEC)
      ZCOSC=DCOS(CLOCK)
      ZSINC=DSIN(CLOCK)
      TEMP=ZRA
      IF(DABS(ZSIND).GT.DECTEST) TEMP=DSIGN(0.75D0*TWOPI,ZSIND)
      ZCOSA=DCOS(TEMP)
      ZSINA=DSIN(TEMP)
C
      A(1,1)=-ZSINA*ZCOSC-ZCOSA*ZSIND*ZSINC
      A(2,1)= ZCOSA*ZCOSC-ZSINA*ZSIND*ZSINC
      A(3,1)= ZCOSD*ZSINC
      A(1,2)= ZSINA*ZSINC-ZCOSA*ZSIND*ZCOSC
      A(2,2)=-ZCOSA*ZSINC-ZSINA*ZSIND*ZCOSC
      A(3,2)= ZCOSD*ZCOSC
      A(1,3)= ZCOSA*ZCOSD
      A(2,3)= ZSINA*ZCOSD
      A(3,3)= ZSIND
C
      IF(KEY.GT.0) GO TO 100
C
      DO 110 I=1,3
      DO 110 J=1,3
  110 MATRIX(I,J)=A(I,J)
      GO TO 9999
C
  100 CONTINUE
      DO 120 I=1,3
      DO 120 J=1,3
  120 MATRIX(I,J)=A(J,I)
C
 9999 CONTINUE
      RETURN
      END


!> Conway's Game of Life.
!>
!> A cellular automata program which utilises:
!> - a 2D grid with hard, torodial or a hybrid boundary,
!> - possible cell states S = {0, 1}; that is, dead or alive,
!> - a Moore neighbourhood; that is, where for a given cell, the cells directly
!>   and diagonally adjacent are considered its neighbours,
!> - Conway's update rule, which updates the state of a cell in accordance with
!>   the following behaviour:
!>   - any live cell with two or three live neighbours continues to live,
!>   - any dead cell with three live neighbours becomes a live cell,
!>   - all other live cells die, and all other dead cells stay dead.
!>
!> This version of the program, 02_gol_cpu_serial_fort, is a serial code, which
!> is only modified from the original code, 01_gol_cpu_serial_fort, in the
!> following ways:
!> - Inner and outer loops over grid(i, j) have been swapped to ensure more
!>   efficient array caching (noting that Fortran is column-major).
!> - Fixed error in game_of_life_stats() which was indexing states from
!>   [1 .. numstates] rather than [0 .. numstates-1].
!> - Cosmetic changes, such as adding white space, and including more detailed
!>   comments.
program GameOfLife
  use gol_common
  implicit none

  interface
    ! GOL prototypes.
    subroutine game_of_life(opt, current_grid, next_grid, n, m)
      use gol_common
      implicit none

      type(Options), intent(in) :: opt
      integer, intent(in) :: n, m
      integer, dimension(:,:), intent(in) :: current_grid
      integer, dimension(:,:), intent(out) :: next_grid
    end subroutine game_of_life

    ! GOL stats protoype.
    subroutine game_of_life_stats(opt, steps, current_grid)
      use gol_common
      implicit none

      type(Options), intent(in) :: opt
      integer, intent(in) :: steps
      integer, dimension(:,:), intent(in) :: current_grid
    end subroutine game_of_life_stats
  end interface

  ! GOL main loop variables.
  type(Options) :: opt
  integer :: n, m, nsteps, current_step
  integer, dimension(:,:), allocatable :: grid, updated_grid
  real*8 :: time1, time2

  ! GOL initialisation.
  call getinput(opt)

  n = opt%n
  m = opt%m
  nsteps = opt%nsteps

  write(*,*) n, m, nsteps

  allocate(grid(n,m))
  allocate(updated_grid(n,m))

  call generate_IC(opt%iictype, grid, n, m)

  ! GOL main loop.
  time1 = init_time()
  current_step = 0

  do while (current_step .ne. nsteps)
    time2 = init_time()

    ! Visualise the current state of the grid according to the visualisation
    ! type selected.
    call visualise(opt%ivisualisetype, current_step, grid, n, m);

    ! Calculate the statistics of the current state of the grid; that is, the
    ! fractional occupation of each state across all cells.
    call game_of_life_stats(opt, current_step, grid);

    ! Calculate the next state of grid according to the Conway update rule.
    call game_of_life(opt, grid, updated_grid, n, m);

    ! Update the current grid variable.
    grid(:,:) = updated_grid(:,:)

    current_step = current_step + 1

    ! Write out the time taken for this loop.
    call get_elapsed_time(time2)

    time2 = init_time()
  end do

  write(*,*) "Finished GOL"

  ! Write out the time taken for the entire program
  call get_elapsed_time(time1);

  ! GOL cleanup.
  deallocate(grid)
  deallocate(updated_grid)
end program GameOfLife

!> GOL
subroutine game_of_life(opt, current_grid, next_grid, n, m)
  use gol_common
  implicit none

  type(Options), intent(in) :: opt
  integer, intent(in) :: n, m
  integer, dimension(:,:), intent(in) :: current_grid
  integer, dimension(:,:), intent(out) :: next_grid
  integer :: neighbours, i, j, k
  integer, dimension(8) :: n_i, n_j

  ! Loop over current grid and determine next grid.
  ! Inner and outer loops have been swapped due to Fortran storing arrays in
  ! column-major order.
  do j = 1, m
    do i = 1, n
      ! Count the number of neighbours, clockwise around the current cell.
      neighbours = 0;

      n_i(1) = i - 1
      n_j(1) = j - 1

      n_i(2) = i - 1
      n_j(2) = j

      n_i(3) = i - 1
      n_j(3) = j + 1

      n_i(4) = i
      n_j(4) = j + 1

      n_i(5) = i + 1
      n_j(5) = j + 1

      n_i(6) = i + 1
      n_j(6) = j

      n_i(7) = i + 1
      n_j(7) = j - 1

      n_i(8) = i
      n_j(8) = j - 1

      ! Loop over all neighbours and check their state. The total number of live
      ! neighbours is accumulated.
      do k = 1, 8
        if(n_i(k) .ge. 1 .and. n_j(k) .ge. 1 .and. &
            n_i(k) .le. n .and. n_j(k) .le. m) then
          if (current_grid(n_i(k), n_j(k)) .eq. CellState_ALIVE) then
            neighbours = neighbours + 1
          end if
        end if
      end do

      ! Set the next grid, according to Conway's update rule.
      if(current_grid(i,j) .eq. CellState_ALIVE .and. &
          (neighbours .eq. 2 .or. neighbours .eq. 3)) then
        next_grid(i,j) = CellState_ALIVE
      else if (current_grid(i,j) .eq. CellState_DEAD .and. neighbours .eq. 3) then
        next_grid(i,j) = CellState_ALIVE
      else
        next_grid(i,j) = CellState_DEAD
      end if
    end do
  end do
end subroutine game_of_life

!> GOL stats
subroutine game_of_life_stats(opt, step, current_grid)
  use gol_common
  implicit none

  type(Options), intent(in) :: opt
  integer, intent(in) :: step
  integer, dimension(:,:), intent(in) :: current_grid
  integer :: i, j, state
  integer*8 :: ntot
  ! num_in_state and frac modified from dimension(NUMSTATES) to
  ! dimension(0:NUMSTATES-1) to synchronise with the 0-based indexing of
  ! states mandated in common_fort.f90.
  integer, dimension(0:NUMSTATES-1) :: num_in_state
  real*8, dimension(0:NUMSTATES-1) :: frac
  character(len=30) :: fmt

  fmt = "(A15,I1,A3,F10.4,A4)"
  ntot = opt%n * opt%m

  num_in_state(:) = 0

  ! Calculated the number of cells in each state across the entire grid.
  ! Inner and outer loops have been swapped due to Fortran storing arrays in
  ! column-major order.
  do j = 1, opt%m
    do i = 1, opt%n
      state = current_grid(i,j)
      num_in_state(state) = num_in_state(state) + 1
    end do
  end do

  ! Converted the state occupation from absolute terms to fractional terms.
  frac(:) = num_in_state(:)/real(ntot)

  if (step .eq. 0) then
    open(10, file=opt%statsfile, access="sequential")
  else
#if defined(_CRAYFTN) || defined(_INTELFTN)
    open(10, file=opt%statsfile, position="append")
#else
    open(10, file=opt%statsfile, access="append")
#endif
  end if

  write(10,*) "step ", step

  ! Loop bounds modified to synchronise with 0-based indexing of frac(:).
  do i = 0, NUMSTATES-1
    write(10,fmt, advance="no") "Frac in state ", i, " = ", frac(i), " "
  end do

  write(10,*) ""
  close(10)
end subroutine game_of_life_stats


module model_vorticity_magnitude
#include <messenger.h>
    use mod_kinds,          only: rk
    use mod_constants,      only: HALF, ONE, TWO
    use mod_fluid,          only: omega
    use type_model,         only: model_t
    use type_chidg_worker,  only: chidg_worker_t
    use DNAD_D
    implicit none

    !>  A model for computing vorticity_magnitude
    !!
    !!  Model Fields:
    !!      : vorticity_magnitude-1
    !!      : vorticity_magnitude-2
    !!      : vorticity_magnitude-3
    !!
    !!  @author Nathan A. Wukie
    !!  @date   02/23/2017
    !!
    !---------------------------------------------------------------------------------------
    type, extends(model_t)  :: vorticity_magnitude_t

    contains

        procedure   :: init
        procedure   :: compute

    end type vorticity_magnitude_t
    !***************************************************************************************

contains

    !>  Initialize the model with a name and the model fields it is contributing to.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   02/23/2017
    !!
    !---------------------------------------------------------------------------------------
    subroutine init(self)
        class(vorticity_magnitude_t), intent(inout)   :: self

        call self%set_name('Vorticity Magnitude')
        call self%set_dependency('f(Grad(Q))')

        call self%add_model_field('Vorticity Magnitude')

    end subroutine init
    !***************************************************************************************

    !>  Routine for computing the Pressure and Temperature.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   12/1/2016
    !!
    !--------------------------------------------------------------------------------------
    subroutine compute(self,worker)
        class(vorticity_magnitude_t),   intent(in)      :: self
        type(chidg_worker_t),           intent(inout)   :: worker

        type(AD_D), allocatable,    dimension(:) :: &
            vort1, vort2, vort3, z_sq, z

        real(rk) :: epsz

        !
        ! Interpolate solution to quadrature nodes
        !
        vort1    = worker%get_field('Vorticity-1', 'value')
        vort2    = worker%get_field('Vorticity-2', 'value')
        vort3    = worker%get_field('Vorticity-3', 'value')

        z_sq = vort1
        z       = vort1

        z_sq = vort1**TWO + vort2**TWO + vort3**TWO

        epsz = 1.0e-6_rk

        ! NEED SCALAR ARGUMENT
!        if (z_sq < epsz) then
!            z = HALF*(epsz + z_sq/epsz)
!
!        else
!            z = sqrt(z_sq)
!
!        end if

        where (z_sq < epsz)
            z = HALF*(epsz + z_sq/epsz)
        elsewhere
            z = sqrt(z_sq)
        end where

        call worker%store_model_field('Vorticity Magnitude', 'value', z)

    end subroutine compute
    !***************************************************************************************

end module model_vorticity_magnitude