!> @brief This function returns the overall index for any step within 2 nested do loops
!>
!> @param[in] i1 the index of the first do loop
!>
!> @param[in] i2 the index of the second do loop
!>
!> @param[in] n2 the end of the second do loop
!>
!> @warning This function assumes that all indexes go from 1 to n (inclusive)
!>

ELEMENTAL FUNCTION func_overall_index_2loops(i1, i2, n2) RESULT(ans)
    USE ISO_FORTRAN_ENV

    IMPLICIT NONE

    ! Declare inputs/outputs ...
    INTEGER(kind = INT64), INTENT(in)                                           :: i1
    INTEGER(kind = INT64), INTENT(in)                                           :: i2
    INTEGER(kind = INT64), INTENT(in)                                           :: n2
    INTEGER(kind = INT64)                                                       :: ans

    ans = i2 + n2 * (i1 - 1_INT64)
END FUNCTION


module mod1
contains
  function array_ret()
       integer :: array_ret(9)
       real :: numbers(9)=(/  5,  6,  3,  8,  9,  1,  7,  4,  2 /)
       array_ret = INT(numbers)
    end function array_ret
end module mod1

    program prog
    use mod1
    integer ::val(9)
    val = array_ret()
    print *,val
    end program prog


      SUBROUTINE MB01RD( UPLO, TRANS, M, N, ALPHA, BETA, R, LDR, A, LDA,
     $                   X, LDX, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the matrix formula
C        _
C        R = alpha*R + beta*op( A )*X*op( A )',
C                                                 _
C     where alpha and beta are scalars, R, X, and R are symmetric
C     matrices, A is a general matrix, and op( A ) is one of
C
C        op( A ) = A   or   op( A ) = A'.
C
C     The result is overwritten on R.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     UPLO    CHARACTER*1                                         _
C             Specifies which triangles of the symmetric matrices R, R,
C             and X are given as follows:
C             = 'U':  the upper triangular part is given;
C             = 'L':  the lower triangular part is given.
C
C     TRANS   CHARACTER*1
C             Specifies the form of op( A ) to be used in the matrix
C             multiplication as follows:
C             = 'N':  op( A ) = A;
C             = 'T':  op( A ) = A';
C             = 'C':  op( A ) = A'.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER           _
C             The order of the matrices R and R and the number of rows
C             of the matrix op( A ).  M >= 0.
C
C     N       (input) INTEGER
C             The order of the matrix X and the number of columns of the
C             the matrix op( A ).  N >= 0.
C
C     ALPHA   (input) DOUBLE PRECISION
C             The scalar alpha. When alpha is zero then R need not be
C             set before entry, except when R is identified with X in
C             the call (which is possible only in this case).
C
C     BETA    (input) DOUBLE PRECISION
C             The scalar beta. When beta is zero then A and X are not
C             referenced.
C
C     R       (input/output) DOUBLE PRECISION array, dimension (LDR,M)
C             On entry with UPLO = 'U', the leading M-by-M upper
C             triangular part of this array must contain the upper
C             triangular part of the symmetric matrix R; the strictly
C             lower triangular part of the array is used as workspace.
C             On entry with UPLO = 'L', the leading M-by-M lower
C             triangular part of this array must contain the lower
C             triangular part of the symmetric matrix R; the strictly
C             upper triangular part of the array is used as workspace.
C             On exit, the leading M-by-M upper triangular part (if
C             UPLO = 'U'), or lower triangular part (if UPLO = 'L'), of
C             this array contains the corresponding triangular part of
C                                 _
C             the computed matrix R. If beta <> 0, the remaining
C             strictly triangular part of this array contains the
C             corresponding part of the matrix expression
C             beta*op( A )*T*op( A )', where T is the triangular matrix
C             defined in the Method section.
C
C     LDR     INTEGER
C             The leading dimension of array R.  LDR >= MAX(1,M).
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,k)
C             where k is N when TRANS = 'N' and is M when TRANS = 'T' or
C             TRANS = 'C'.
C             On entry with TRANS = 'N', the leading M-by-N part of this
C             array must contain the matrix A.
C             On entry with TRANS = 'T' or TRANS = 'C', the leading
C             N-by-M part of this array must contain the matrix A.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,l),
C             where l is M when TRANS = 'N' and is N when TRANS = 'T' or
C             TRANS = 'C'.
C
C     X       (input/output) DOUBLE PRECISION array, dimension (LDX,N)
C             On entry, if UPLO = 'U', the leading N-by-N upper
C             triangular part of this array must contain the upper
C             triangular part of the symmetric matrix X and the strictly
C             lower triangular part of the array is not referenced.
C             On entry, if UPLO = 'L', the leading N-by-N lower
C             triangular part of this array must contain the lower
C             triangular part of the symmetric matrix X and the strictly
C             upper triangular part of the array is not referenced.
C             On exit, each diagonal element of this array has half its
C             input value, but the other elements are not modified.
C
C     LDX     INTEGER
C             The leading dimension of array X.  LDX >= MAX(1,N).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, the leading M-by-N part of this
C             array (with the leading dimension MAX(1,M)) returns the
C             matrix product beta*op( A )*T, where T is the triangular
C             matrix defined in the Method section.
C             This array is not referenced when beta = 0.
C
C     LDWORK  The length of the array DWORK.
C             LDWORK >= MAX(1,M*N), if  beta <> 0;
C             LDWORK >= 1,          if  beta =  0.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -k, the k-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The matrix expression is efficiently evaluated taking the symmetry
C     into account. Specifically, let X = T + T', with T an upper or
C     lower triangular matrix, defined by
C
C        T = triu( X ) - (1/2)*diag( X ),  if UPLO = 'U',
C        T = tril( X ) - (1/2)*diag( X ),  if UPLO = 'L',
C
C     where triu, tril, and diag denote the upper triangular part, lower
C     triangular part, and diagonal part of X, respectively. Then,
C
C        op( A )*X*op( A )' = B + B',
C
C     where B := op( A )*T*op( A )'. Matrix B is not symmetric, but it
C     can be written as tri( B ) + stri( B ), where tri denotes the
C     triangular part specified by UPLO, and stri denotes the remaining
C     strictly triangular part. Let R = V + V', with V defined as T
C     above. Then, the required triangular part of the result can be
C     written as
C
C        alpha*V + beta*tri( B )  + beta*(stri( B ))' +
C                 alpha*diag( V ) + beta*diag( tri( B ) ).
C
C     REFERENCES
C
C     None.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires approximately
C
C         2             2
C        M x N + 1/2 x N x M
C
C     operations.
C
C     CONTRIBUTORS
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004,
C     Apr. 2004, Sep. 2013.
C
C     KEYWORDS
C
C     Elementary matrix operations, matrix algebra, matrix operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, HALF
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, HALF = 0.5D0 )
C     .. Scalar Arguments ..
      CHARACTER         TRANS, UPLO
      INTEGER           INFO, LDA, LDR, LDWORK, LDX, M, N
      DOUBLE PRECISION  ALPHA, BETA
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), DWORK(*), R(LDR,*), X(LDX,*)
C     .. Local Scalars ..
      CHARACTER*12      NTRAN
      LOGICAL           LTRANS, LUPLO
      INTEGER           J, JWORK, LDW, NROWA
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY, DGEMM, DLACPY, DLASCL, DLASET,
     $                  DSCAL, DTRMM, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO = 0
      LUPLO  = LSAME( UPLO,  'U' )
      LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
C
      IF ( LTRANS ) THEN
         NROWA = N
         NTRAN = 'No transpose'
      ELSE
         NROWA = M
         NTRAN = 'Transpose'
      END IF
C
      LDW = MAX( 1, M )
C
      IF(      ( .NOT.LUPLO  ).AND.( .NOT.LSAME( UPLO,  'L' ) ) )THEN
         INFO = -1
      ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDR.LT.LDW ) THEN
         INFO = -8
      ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN
         INFO = -10
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -12
      ELSE IF( ( BETA.NE.ZERO .AND. LDWORK.LT.MAX( 1, M*N ) )
     $     .OR.( BETA.EQ.ZERO .AND. LDWORK.LT.1 ) ) THEN
         INFO = -14
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB01RD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      CALL DSCAL( N, HALF, X, LDX+1 )
      IF ( M.EQ.0 )
     $   RETURN
C
      IF ( BETA.EQ.ZERO .OR. N.EQ.0 ) THEN
         IF ( ALPHA.EQ.ZERO ) THEN
C
C           Special case alpha = 0.
C
            CALL DLASET( UPLO, M, M, ZERO, ZERO, R, LDR )
         ELSE
C
C           Special case beta = 0 or N = 0.
C
            IF ( ALPHA.NE.ONE )
     $         CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, M, M, R, LDR, INFO )
         END IF
         RETURN
      END IF
C
C     General case: beta <> 0. Efficiently compute
C        _
C        R = alpha*R + beta*op( A )*X*op( A )',
C
C     as described in the Method section.
C
C     Compute W = beta*op( A )*T in DWORK.
C     Workspace: need M*N.
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code.)
C
      IF( LTRANS ) THEN
         JWORK = 1
C
         DO 10 J = 1, N
            CALL DCOPY( M, A(J,1), LDA, DWORK(JWORK), 1 )
            JWORK = JWORK + LDW
 10      CONTINUE
C
      ELSE
         CALL DLACPY( 'Full', M, N, A, LDA, DWORK, LDW )
      END IF
C
      CALL DTRMM( 'Right', UPLO, 'No transpose', 'Non-unit', M, N, BETA,
     $            X, LDX, DWORK, LDW )
C
C     Compute Y = alpha*V + W*op( A )' in R. First, set to zero the
C     strictly triangular part of R not specified by UPLO. That part
C     will then contain beta*stri( B ).
C
      IF ( ALPHA.NE.ZERO ) THEN
         IF ( M.GT.1 ) THEN
            IF ( LUPLO ) THEN
               CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, R(2,1), LDR )
            ELSE
               CALL DLASET( 'Upper', M-1, M-1, ZERO, ZERO, R(1,2), LDR )
            END IF
         END IF
         CALL DSCAL( M, HALF, R, LDR+1 )
      END IF
C
      CALL DGEMM( 'No transpose', NTRAN, M, M, N, ONE, DWORK, LDW, A,
     $            LDA, ALPHA, R, LDR )
C
C     Add the term corresponding to B', with B = op( A )*T*op( A )'.
C
      IF( LUPLO ) THEN
C
         DO 20 J = 1, M
            CALL DAXPY( J, ONE, R(J,1), LDR, R(1,J), 1 )
   20    CONTINUE
C
      ELSE
C
         DO 30 J = 1, M
            CALL DAXPY( J, ONE, R(1,J), 1, R(J,1), LDR )
 30      CONTINUE
C
      END IF
C
      RETURN
C *** Last line of MB01RD ***
      END


  subroutine kinema (coalObj, pstar, v, p, ct, st, cfi, sfi, t, cm)

! ======================================================================
!
!     Kinematics routine.
!     Lorentz transformation of the 3-momentum pstar in the center
!     of mass system to p in the laboratory system; t is the lab
!     kinetic energy.  v is the velocity of the CM in the lab system.
!
!    Called by: PAULIP PRECOF COALESL
!
!    CEM95 written by S. G. Mashnik
!    Edited by A. J. Sierk,  LANL T-2, February, 1996.
!    Edited by AJS, October, 1997.
!    Edited by A. J. Sierk, LANL T-16, October, 2003.
!    Edited by AJS, LANL T-2, December, 2011.
!    Edited by LMK, XCP-3, July 2013 (included error protection)
!    Edited by CMJ, XCP-3, July 2018 (included verbose filter)
!
! ======================================================================

    use, intrinsic :: iso_fortran_env, only: real64
    use coalescenceParams, only : zro, one

    implicit none
    class(Coalescence),         intent(inout) :: coalObj
    real(real64), dimension(3), intent(in)    :: pstar
    real(real64), dimension(3), intent(in)    :: v
    real(real64), dimension(3), intent(out)   :: p
    real(real64),               intent(out)   :: ct
    real(real64),               intent(out)   :: st
    real(real64),               intent(out)   :: cfi
    real(real64),               intent(out)   :: sfi
    real(real64),               intent(out)   :: t
    real(real64),               intent(in)    :: cm

    real(real64) :: pm, pms, pmstars, spv, temp, temp1, temp2, temp3, &
         & temp4, v2

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

    spv = pstar(1)*v(1) + pstar(2)*v(2) + pstar(3)*v(3)
    v2 = v(1)**2 + v(2)**2 + v(3)**2
    temp1 = sqrt(abs(one - v2))
    if (temp1 < div0Limit .and. temp1 > -div0Limit) then
       temp1 = div0Limit
       write(coalObj%io%message, 1000) "46, 49"
       call coalObj%io%print(4, 3, coalObj%io%message)
    end if
    temp = v2
    if (temp < div0Limit .and. temp > -div0Limit) then
       temp = div0Limit
       write(coalObj%io%message, 1000) "46, 49"
       call coalObj%io%print(4, 3, coalObj%io%message)
    end if
    temp2 = spv*(one/temp1 - one)/temp
    pmstars = pstar(1)**2 + pstar(2)**2 + pstar(3)**2
    temp3 = sqrt(pmstars + cm**2)
    temp1 = temp3/temp1
    temp3 = temp1 + temp2
    p(1) = pstar(1) + v(1)*temp3
    p(2) = pstar(2) + v(2)*temp3
    p(3) = pstar(3) + v(3)*temp3
    pms = p(1)**2 + p(2)**2 + p(3)**2
    pm = sqrt(pms)
    temp = pm
    if (temp < div0Limit .and. temp > -div0Limit) then
       temp = div0Limit
       write(coalObj%io%message, 1000) "61"
       call coalObj%io%print(4, 3, coalObj%io%message)
    end if
    ct = p(3)/temp
    temp4 = one - ct**2
    if (temp4 <= zro) then
       ct = one
       cfi = one
       sfi = zro
       st = zro
    else
       st = sqrt(temp4)
       temp3 = pm*st
       if (temp3 < div0Limit .and. temp3 > -div0Limit) then
          temp3 = div0Limit
          write(coalObj%io%message, 1000) "75, 76"
          call coalObj%io%print(4, 3, coalObj%io%message)
       end if
       cfi = p(1)/temp3
       sfi = p(2)/temp3
    endif
    t = sqrt(pms + cm**2) - cm
    return

! ======================================================================
1000 format("Divide by zero error prevented in ", &
          & "'kinema.f90', line(s) ", A)
! ======================================================================
  end subroutine kinema


      SUBROUTINE PT3PL (X,Y,Z, A,B,C,D)

      REAL   X(3),Y(3),Z(3), A,B,C,D

C Given 3 points, find containing plane
      A = Y(2)*Z(3) + Y(3)*Z(1) + Y(1)*Z(2)
     1  - Y(1)*Z(3) - Y(2)*Z(1) - Y(3)*Z(2)
      B = Z(2)*X(3) + Z(3)*X(1) + Z(1)*X(2)
     1  - Z(1)*X(3) - Z(2)*X(1) - Z(3)*X(2)
      C = X(2)*Y(3) + X(3)*Y(1) + X(1)*Y(2)
     1  - X(1)*Y(3) - X(2)*Y(1) - X(3)*Y(2)

      D = - (A*X(1) + B*Y(1) + C*Z(1) +
     1       A*X(2) + B*Y(2) + C*Z(2) +
     2       A*X(3) + B*Y(3) + C*Z(3)) / 3

      END


Real Function fns(dmass, srt, con)
  Save
  width = 0.2
  amn = 0.938869
  avpi = 0.13803333
  an0 = 1.43
  fn = 4.*(an0**2)*width/((dmass**2-1.44**2)**2+an0**2*width**2)
  If (con==1.) Then
     scheck = (srt**2+dmass**2-amn**2)**2/(4.*srt**2) - dmass**2
     If (scheck<0) Then
        Write (99, *) 'scheck13: ', scheck
        scheck = 0.
     End If
     p1 = sqrt(scheck)
  Else
     dmass = amn + avpi
     scheck = (srt**2+dmass**2-amn**2)**2/(4.*srt**2) - dmass**2
     If (scheck<0) Then
        Write (99, *) 'scheck14: ', scheck
        scheck = 0.
     End If
     p1 = sqrt(scheck)
  End If
  fns = fn*p1*dmass
  Return
End Function fns


c     Subroutine to calculate statistical package
c     AJ_Kettle, Oct26/2017

      SUBROUTINE dwd_subday_stat_pack(l_mlent,j_sd,f_ndflag,
     +  ft_sd_pres_hpa,

     +  ft_sd_pres_min_hpa,ft_sd_pres_max_hpa,
     +  ft_sd_pres_avg_hpa,
     +  ft_sd_pres_ngood,ft_sd_pres_nbad)

      IMPLICIT NONE
c************************************************************************
      INTEGER             :: l_mlent
      INTEGER             :: j_sd
      REAL                :: f_ndflag
      REAL                :: ft_sd_pres_hpa(l_mlent)
      INTEGER             :: i,j,k,ii,jj,kk
      INTEGER             :: i_good

      REAL                :: ft_sd_pres_ngood
      REAL                :: ft_sd_pres_nbad
      REAL                :: ft_sd_pres_min_hpa
      REAL                :: ft_sd_pres_max_hpa
      REAL                :: ft_sd_pres_tot_hpa
      REAL                :: ft_sd_pres_avg_hpa
c************************************************************************
c      print*,'l_mlent,j_sd=',l_mlent,j_sd
c      print*,'ft_sd_pres_hpa=',(ft_sd_pres_hpa(i),i=1,10)

      i_good   =0
      ft_sd_pres_ngood   =0.0
      ft_sd_pres_nbad    =0.0
      ft_sd_pres_min_hpa =-f_ndflag
      ft_sd_pres_max_hpa =f_ndflag
      ft_sd_pres_tot_hpa =0.0

      DO i=1,j_sd
       IF (ft_sd_pres_hpa(i).NE.f_ndflag) THEN

        ft_sd_pres_min_hpa=MIN(ft_sd_pres_min_hpa,ft_sd_pres_hpa(i))
        ft_sd_pres_max_hpa=MAX(ft_sd_pres_max_hpa,ft_sd_pres_hpa(i))
        ft_sd_pres_tot_hpa=ft_sd_pres_tot_hpa+ft_sd_pres_hpa(i)

        ft_sd_pres_ngood=ft_sd_pres_ngood+1.0
        i_good=i_good+1
       ENDIF
       IF (.NOT.(ft_sd_pres_hpa(i).NE.f_ndflag)) THEN
        ft_sd_pres_nbad=ft_sd_pres_nbad+1.0
       ENDIF
      ENDDO

      IF (ft_sd_pres_ngood.GE.1.0) THEN
       ft_sd_pres_avg_hpa=ft_sd_pres_tot_hpa/ft_sd_pres_ngood
      ENDIF
      IF (.NOT.(ft_sd_pres_ngood.GE.1.0)) THEN
       ft_sd_pres_avg_hpa=f_ndflag
       ft_sd_pres_min_hpa=f_ndflag
       ft_sd_pres_max_hpa=f_ndflag
      ENDIF

c      print*,'ft_sd_pres_ngood=', ft_sd_pres_ngood
c      print*,'ft_sd_pres_nbad=',  ft_sd_pres_nbad
c      print*,'ft_sd_pres_min_hpa',ft_sd_pres_min_hpa
c      print*,'ft_sd_pres_max_hpa',ft_sd_pres_max_hpa
c      print*,'ft_sd_pres_avg_hpa',ft_sd_pres_avg_hpa

      RETURN
      END


	PROGRAM CALCOMP
C
C	CALCULATES GAIN AND PHASE SHIFT OF X AND Y,Z CAL SIGNALS
C
	COMPLEX VX,VYZ,Y2,Z1,Z2,ZTERM
	DATA R5X,R5YZ /3900.,1000./
	DATA R4 /1.E4/
	DATA R34X,R34YZ /150.,51./
	DATA C24X,C24YZ /680.E-12,2.2E-9/
	DATA TWOPI /6.2831853/
C
	DO N = 1,60
	  F = 1000.*N
	  W= TWOPI*F
C		DO X PREAMP
	  ZTERM = CMPLX(R34X,-1./W/C24X)
	  Y2 = 1./ZTERM + 1./R5X
	  Z2 = 1./Y2
	  VX = Z2/(R4 + Z2)
C		DO Y,Z PREAMP
	  ZTERM = CMPLX(R34YZ,-1./W/C24YZ)
	  Y2 = 1./ZTERM + 1./R5YZ
	  Z2 = 1./Y2
	  VYZ = Z2/(R4 + Z2)
	  RGAIN = CABS(VX)/CABS(VYZ)
	  DB = 20.*ALOG10(RGAIN)
	  REX = REAL(VX)
	  REYZ = REAL(VYZ)
	  XIM = AIMAG(VX)
	  YZIM = AIMAG(VYZ)
	  PHX = (360./TWOPI)*ATAN2(XIM,REX)
	  PHYZ = (360./TWOPI)*ATAN2(YZIM,REYZ)
	  PHASE = (PHX - PHYZ)
	  PRINT 101,  F,RGAIN,DB,PHX,PHYZ,PHASE
	  WRITE(77,101) F,RGAIN,DB,PHX,PHYZ,PHASE
 101	  FORMAT(F10.1,F8.4,F6.2,3F7.2)
	ENDDO
	STOP
	END


program modecoupmat_square

  use fieldinfo_
  use sub_
  implicit none

  integer :: np,np2,i,j,i1,j1,im,dj
  integer, parameter :: immax=4
  real ::  lx,ly,labs,num_part(npmax),num(npmax),fac
  double precision :: dmat(npmax,immax),mat_part(npmax,npmax,immax),mat(npmax,npmax,immax)
  double precision :: mat3(npmax3,npmax3),lside(2)
  character ::  outf*150,cform*150

  include 'mpif.h'
  integer :: rank,size,ierror,status(MPI_STATUS_SIZE)
  integer :: jstart,jend

  call MPI_INIT(ierror)
  call MPI_COMM_SIZE(MPI_COMM_WORLD,size,ierror)
  call MPI_COMM_RANK(MPI_COMM_WORLD,rank,ierror)

  call getarg(1,outf)
  call binninginit

  if (rank==0) write(*,*) 'Start computing the convolution matrix due to a square patch of sky'

  mat3=0.d0

  lside(1)=rad1
  lside(2)=rad2

  call jstartend(size,rank,jstart,jend,lside)
  write(*,*) rank,jstart,jend

  mat_part=0.d0
  num_part=0.
  dj=jend-jstart+1
  do j=jstart,jend
     if (mod(j,4)==0) write(*,*) 'rank:',rank, int(100.*(j-jstart)/dj),'% finish'
     j1 = j-1
     do i=j,ni/2+1
        i1 = i-1

        lx=float(i1)/lside(1)*(2.*pi)
        ly=float(j1)/lside(2)*(2.*pi)
        labs=sqrt(lx*lx+ly*ly)

        if (labs<llowbin(1)) cycle
        if (labs>=llowbin(npmax+1)) cycle

        np=1
        do while (labs>=llowbin(np))
           np=np+1
        enddo
        np=np-1

        call matcomp(lx,ly,dmat,immax,lside)

        if ((j1==0).or.(i1==j1)) then
           fac=1.
        else
           fac=2.
        endif

        do np2=1,npmax
           do im=1,immax
              mat_part(np,np2,im)=mat_part(np,np2,im)+dmat(np2,im)*fac
           enddo
        enddo
        num_part(np)=num_part(np)+fac

     enddo
  enddo

  call MPI_REDUCE(num_part,num,npmax,MPI_REAL,MPI_SUM,0,MPI_COMM_WORLD,ierror)

  mat=0.d0
  do im=1,immax
     do np2=1,npmax
        call MPI_REDUCE(mat_part(:,np2,im),mat(:,np2,im),npmax,MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD,ierror)
     enddo
  enddo

  if (rank==0) then

     do np=1,npmax
        do np2=1,npmax
           do im=1,immax
              if (num(np)>0) then
                 mat(np,np2,im)=mat(np,np2,im)/num(np)
              else
                 if (np==np2.and.im/=2) mat(np,np2,im)=1.d0
              endif
           enddo
        enddo
     enddo

     do np=1,npmax
        do np2=1,npmax
           mat3(np,np2)=mat(np,np2,1)
           mat3(np,np2+npmax)=mat(np,np2,2)
           mat3(np+npmax,np2)=mat(np,np2,2)
           mat3(np+npmax,np2+npmax)=mat(np,np2,1)
           mat3(np+npmax2,np2+npmax2)=mat(np,np2,1)-mat(np,np2,2)
        enddo
     enddo

  endif

  if (rank==0) then

     cform='(2(i4,1x),(1pe15.8,1x))'

     write(*,*) 'output file: ',outf(1:len_trim(outf))
     open(2,file=outf,status='unknown')
     do np=1,npmax3
        do np2=1,npmax3
           write(2,cform) np,np2,mat3(np,np2)
        enddo
        write(2,*)
     enddo
     close(2)

  endif

  write(*,*) 'finish calculation: rank',rank,jstart,jend
  call MPI_FINALIZE(ierror)

contains

  subroutine matcomp(qx,qy,dmat,immax,lside)

    implicit none

    integer ::  ik,is,ismax,np
    integer, intent(in) :: immax
    real ::  qx,qy,q,cosi,sini,ds,theta,kpara,kperp,labs,pbl,qbl,s2,c2
    real ::  kx,ky,winx,winy,win,rx,ry,gx,gy
    integer :: ikmax1,ikmax
    integer, parameter :: iklim=ni*100
    real ::  kf,knyq,kmax2,dk1,kmax1,dk2,k(iklim),dk(iklim)
    double precision ::  dmat(npmax,immax)
    double precision, intent(in) :: lside(2)

    q=sqrt(qx*qx+qy*qy)
    cosi=qx/q
    sini=qy/q

    pbl=q*(q+1)/2./pi

!!!
!  integral range of k is set from 0 to knyq/5.
!  From 0 to kf*4, binning width is kf/100.
!  From kf*4 to knyq/5, binning width is kf/4.

    kf=2.*pi/lside(1)
    knyq=kf*(ni/2)

    kmax2=knyq/5.
    dk1=kf/100.
    ikmax1=400
    kmax1=dk1*ikmax1
    dk2=kf/4.
    ikmax=ikmax1+nint((kmax2-kmax1)/dk2)

    do ik=1,ikmax1
       dk(ik)=dk1
       k(ik)=dk1*(ik-0.5)
    enddo

    do ik=ikmax1+1,ikmax
       dk(ik)=dk2
       k(ik)=kmax1+dk2*(ik-ikmax1-0.5)
    enddo

    dmat=0.d0

    do ik=1,ikmax
       ismax=2*max(ik,200)
       ds=2.*pi/ismax
       do is=1,ismax
          theta=ds*(is-1.)
          kpara=k(ik)*cos(theta)
          kperp=k(ik)*sin(theta)
          labs=sqrt(q*q+k(ik)*k(ik)+2.*kpara*q)

          qbl=2.*pi/labs/(labs+1)

          s2=(kperp/labs)**2
          c2=1.-s2

          kx=kpara*cosi-kperp*sini
          ky=kpara*sini+kperp*cosi

          rx=nint((qx+kx)/kf)*kf
          ry=nint((qy+ky)/kf)*kf

          labs=sqrt(rx*rx+ry*ry)
          if (labs<llowbin(1)) cycle
          if (labs>=llowbin(npmax+1)) cycle

          np=1
          do while (labs>=llowbin(np))
             np=np+1
          enddo
          np=np-1

          gx=kx/kf
          gy=ky/kf
          call recwin(gx,ni,winx)
          call recwin(gy,nj,winy)
          winx=winx/kf
          winy=winy/kf
          win=winx*winy
          dmat(np,1)=dmat(np,1)+k(ik)*dk(ik)*ds*(c2-s2)*(c2-s2)*win*qbl
          dmat(np,2)=dmat(np,2)+k(ik)*dk(ik)*ds*4*s2*c2*win*qbl
          dmat(np,3)=dmat(np,3)+k(ik)*dk(ik)*ds*(c2-s2)*win*qbl
          dmat(np,4)=dmat(np,4)+k(ik)*dk(ik)*ds*win*qbl
       enddo
    enddo

    dmat=dmat*pbl

  end subroutine matcomp

  subroutine jstartend(size,rank,jstart,jend,lside)

    implicit none

    integer :: i,j,i1,j1
    integer, intent(in) :: size,rank
    integer, intent(out) :: jstart,jend
    integer :: nmode,neach
    double precision :: lx,ly,labs
    double precision, intent(in) :: lside(2)

    nmode=0
    do j=1,nj/2+1
       j1=j-1
       do i=j,ni/2+1
          i1=i-1
          lx=i1*(2*pi/lside(1))
          ly=j1*(2*pi/lside(2))
          labs=sqrt(lx*lx+ly*ly)
          if (labs<llowbin(1)) cycle
          if (labs>=llowbin(npmax+1)) cycle
          nmode=nmode+1
       enddo
    enddo
    neach=nmode/size

    nmode=0
    do j=1,nj/2+1
       j1=j-1
       do i=j,ni/2+1
          i1=i-1
          lx=i1*(2*pi/lside(1))
          ly=j1*(2*pi/lside(2))
          labs=sqrt(lx*lx+ly*ly)
          if (labs<llowbin(1)) cycle
          if (labs>=llowbin(npmax+1)) cycle
          nmode=nmode+1
       enddo
       if (nmode<=neach*rank) jstart=j+1
       if (nmode<=neach*(rank+1)) jend=j
    enddo

    if (rank==0) jstart=1
    if (rank==size-1) jend=nj/2+1

  end subroutine jstartend

end program Modecoupmat_square


*+ bfield_spiral

      subroutine bfield_calc   ( flux, s, th1, th2, Bfield, status)
c     -------------------------------------------------------------
c
c calculate the minimum energy magnetic field
c
C Given:
C    flux
       real*4     flux
C    line-of-sight depth
       real*4     s
C    angular isze of region
       real*4     th1, th2
C Returned:
C    euipartition magnetic field strength
       real*4     Bfield
C Updated:
C    error status
       integer    status
C
C-
C Local variables
      real*4         B1,B2,B3,B4

      include 'synch_bfield.inc'

      if (status .ne. 0) return
      if (flux.gt.0.0) then
        B1 = ((nu_lo**(0.5-alpha)) - (nu_hi**(0.5-alpha)))/(alpha-0.5)
        B2 = B1*flux*(nu_zero**alpha)*(1.0+k)/f
        B3 = (1.0+z)**(3.0+alpha)
        B4 = B2*B3/(s*th1*th2)
        Bfield = c_zero*(B4**(2.0/7.0))
      else
        Bfield = 0.0
      endif
      call iocmd_err( status, 'bfield_calc', ' ')
      end
C
C
C
C
*+ bfield_set

       subroutine bfield_set(status)
C      -----------------------------
C
C Set parameters for the B-field analysis
C
C Updated:
C  error status
       integer     status
C
C-

       include 'synch_bfield.inc'

C check status on entry
       if (status.ne.0) return
       call io_getr('Filling-factor : ','1.0',f,status)
       call io_getr('Energy-ratio : ','0.0',k,status)
       call io_getr('Observation-frequency (/GHz) : ','1',
     *              nu_zero,status)
       call io_getr('Low-frequency integration limit (/GHz) : ',
     *             '0.01',nu_lo,status)
       call io_getr('High-frequency integration limit (/GHz) : ',
     *             '100',nu_hi,status)
       call io_getr('Spectral-index : ','0.5',alpha,status)
       call io_getr('Redshift : ','0.0',z,status)
       call iocmd_err(status,'EQUIPARTITION-PARAMETERS',' ')

       end
C
C
*+ bfield_spiral

      subroutine bfield_spiral (minirt, map, iuv,
     *                          flx_lvl, flx_nrm, theta_r, s,
     *                          flux, Bfield, status)
c     ----------------------------------------------------
c
c calculate the minimum energy magnetic field for a spiral galaxy model
c
C Given:
C    mini redtape
       integer  minirt(10)
C    map data
       real*4   map(*)
C    data range
       integer  iuv(4)
C    flux level below which pixels are ignored
       real*4   flx_lvl
C    flux normalization constant
       real*4   flx_nrm
C    disc semi-major axis
       real*4   theta_r
C    line-of-sight depth
       real*4   s
C Returned:
C    flux within window, above flx_lvl (Jansky)
       real*4   flux
C    euipartition magnetic field strength
       real*4   Bfield
C Updated:
C    error status
       integer    status
C
C-
C Local variables
      integer*4      i, j, uv(2)
      equivalence   (uv(1), i)
      equivalence   (uv(2), j)
      real*4         map_data
      real*4         sum,B1,B2,B3,B4

       include '/mrao/include/constants.inc'
       include 'synch_bfield.inc'

      if (status .ne. 0) return

      sum = 0.0
      do j = iuv(3),iuv(4),-1
        do i = iuv(1),iuv(2)
          call iuvval2(minirt,map,uv,map_data,status)
          if (map_data .ge. flx_lvl) sum = sum + map_data
        end do
      end do
      flux = flx_nrm*sum

c B3 is model dependent - thin disc model for spiral
      if (flux.gt.0.0) then
        B1 = (nu_lo**(0.5-alpha)) - (nu_hi**(0.5-alpha))/(alpha-0.5)
        B2 = B1*flux*(nu_zero**alpha)*(1.0+k)/f
        B3 = (1.0+z)**(3.0+alpha)
        B4 = B2*B3/(s*const_pi*(theta_r**2))
        Bfield = c_zero*(B4**(2.0/7.0))
      else
        Bfield = 0.0
      endif
      call iocmd_err( status, 'bfield_spiral', ' ')
      end
C
C
C
C
*+ do_B_spiral

       subroutine do_B_spiral(map_array, results, status)
C      --------------------------------------------------
C
C Determine B-field for a spiral galaxy model
C
C Given:
C   Map data array
       real*4     map_array(*)
C
C Updated:
C   Results string
       character*(*) results
C   Status
       integer    status
C
*-
C
       integer    iuv(4), i, imap, ip_map, lr
       integer    uv_pos_1(2), uv_pos_2(2)
       real*4     flux, theta_r, bfield, s
       real*4     flux_level, x, y
       integer    iopt, minirt(8)
       real*8     usamp,vsamp
       real*4     flxnrm, beam(2), posa
       character  option*1

C set status and read in a map
       if (status.ne.0) return
       call map_getmap('Map : ','Default-Map','READ',imap,status)
       call map_alloc_in(imap,'DIRECT',map_array,ip_map,status)
       call enminirt(minirt,status)
       call ensamp(usamp, vsamp, status)
       call enbeam(flxnrm, beam, posa, status)

C get map region
       do i =1,4
         iuv(i) = minirt(i)
       end do
       call plot_getuv('UV-range : ','*',iuv,status)

C mark the required contour level
       call io_getr('Scale-height (kpc) : ','1.0',s,status)
       call plot_getpos2(minirt,'Mark-Cursor : ',' ',uv_pos_1,status)
       call iuvval2(minirt,map_array(ip_map),uv_pos_1,
     *              flux_level,status)
       call io_wrout('Option       C=mark-Core')
       call io_wrout('             D=mark-Diameter')
       call io_wrout('             R=Repeat-first-point')
       call io_wrout('             Q=quit')
1      call io_getkey('Option [C] : ','C','CDRQ',option,status)
       if (option.eq.'R') then
         call plot_getpos2(minirt,'UV-position : ',' ',uv_pos_1,status)
         iopt = 1
         goto 1
       else if (option.eq.'C') then
         call plot_getpos2(minirt,'UV-position : ',' ',uv_pos_2,status)
         iopt = 2
         x = (uv_pos_1(1)-uv_pos_2(1))*usamp
         y = (uv_pos_1(2)-uv_pos_2(2))*vsamp
       else if (option.eq.'D') then
         call plot_getpos2(minirt,'UV-position : ',' ',uv_pos_1,status)
         iopt = 3
         x = (uv_pos_1(1)-uv_pos_2(1))*usamp/2.0
         y = (uv_pos_1(2)-uv_pos_2(2))*vsamp/2.0
       else
         iopt = 4
         goto 100
       end if
       theta_r = sqrt(x*x+y*y)

C determine field for this region
       call bfield_spiral(map_array(ip_map),iuv,flux_level,
     *                    flxnrm,theta_r,s,flux,bfield,status)

       if (status.ne.0) goto 100
       call chr_chrtoc(Bfield,results,lr)

100    call map_end_alloc(imap,map_array,status)
       call iocmd_err(status,'BFIELD-SPIRAL','Failed')

       end
C
C
*+ do_B_calc

       subroutine do_bfield_calc ( results, status )
C      ---------------------------------------------
C
C Do an equipartition calculation
C
C Updated:
C   Results string
       character*(*) results
C   error status
       integer       status
C-
       real*4  s, th1, th2, flux, Bfield
       integer lr
       call io_getr('Line-of-sight-depth (kpc) : ','1',s,status)
       call io_getr('Angular-size 1 (arcsec) : ','1',th1,status)
       call io_getr('Angular-size 2 (arcsec) : ','1',th2,status)
       call io_getr('Flux (mJy) : ','0.0',flux, status )
       flux = flux/1000.0
       call bfield_calc(flux, s, th1, th2, Bfield, status)
       call chr_chrtoc(Bfield,results,lr)
       call iocmd_err(status,'equipartition_calculation',' ')
       end


!!!!!!!!!!!!!!!!!NOTE!!!!!!!!!!!!!!!!!!!!!!!!
!!!! O2- species 1;O - species 2;!!!!!!!!!!!!
!!!!RK-2 Method!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

program main
implicit none

real(8),parameter :: Runiv=8314.34d0,M1=32d0,M2=16d0,TB1=1d0,TB2=3d0,Cf=2.75e16,eta=-1d0, &
                     theta=59500d0,Ti= 4150,rhoi=3.35e-4                                                              !intial,fixed values

real(8),parameter,dimension(7) :: A1=(/3.660960830d+00,6.56365523d-04,-1.41149485d-07, &                   ! O2 aboveT=1000K
                                       2.05797658d-11,-1.29913248d-15,-1.21597725d+03,3.41536184d+00/), &
                                  A2=(/2.54363697d+00,-2.73162486d-05,-4.19029520d-09, &                   ! O  aboveT=1000K
                                       4.95481845d-12,-4.79553694d-16,2.92260120d+04,4.92229457d+00/)
real(8),parameter,dimension(7) :: B1=(/3.78245636d+00,-2.99673415d-03,9.84730200d-06,  &
                                      -9.68129508d-09,3.24372836d-12,-1.06394356d+03,3.65767573d+00/), &    ! O2 below T=1000K
                                  B2=(/3.16826710d+00,-3.27931884d-03,6.64306396d-06,  &
                                      -6.12806624d-09,2.11265971d-12,2.91222592d+04,2.05193346d+00/)        ! O below T=1000K
real(8),dimension(7):: A,B,A1h,B1h,A2h,B2h

real(8) :: T,rho1,rho2,kf,hi,ei,e1,e2,engi,eng,eng1,eng2,h1,h2,d1dt,gp,gr,dg,keq,dt,deng,dengdT,time,k1,k2, &
           rho1sp,rho2sp,res,res0

integer :: nitermax,nmax,n,i
rho1=0d0
rho2=0d0
T=Ti
dt= 1e-6
nitermax = 1000
nmax = 100000000
time=0

! Cp/Runiv formula for curve fitting
! Cp/Runiv = a(1)+a(2)*T+a(3)*T**2+a(4)*T**3+a(5)*T**4+a(6)+a(7)
!!!! a = [A,B,C,D,E,F,G], for Enthalpy/Runiv calculation, divide by molecular weight for the constants

 A1h=A1/32;
 A2h=A2/16;
 B1h=B1/32;
 B2h=B2/16;

!!!!!!! intial condition
!!!h/R(molar)=Cp/Runiv = a(1)*T+a(2)*T**2/2+a(3)*T**3/3+a(4)*T**4/4+a(5)*T**5/5+a(6)
!!!h/R(mass) we divided coefficients  above by Molecular weight
rho1=rhoi
rho2=rhoi-rho1
hi =Runiv*(A1h(1)*Ti        &
      +A1h(2)*(Ti**2)/2     &
      +A1h(3)*(Ti**3)/3     &
      +A1h(4)*(Ti**4)/4     &
      +A1h(5)*(Ti**5)/5     &
      +A1h(6))

ei  = hi - Runiv*Ti/M1
engi=rhoi*ei

!print*, engi

!!!!!!!!!!!
!!!!!!!check if the temperature is above or below 1000K!!!!!!
!!!!!!!!!!!

open (unit = 2, file = "data.dat")
!!!Loop starts
!!!!!!!!!
!!!!!!!!!
do i=1,nmax

if (T<=1000) then
A=B1h
B=B2h
elseif (T>1000) then
A=A1h
B=A2h
endif

!!!!!!keq,kf computation

gr = Runiv*M1*(A(1)*(1-log(T))*T         &
   -A(7)*T                        &
   -A(2)*(T**2)/2                 &
   -A(3)*(T**3)/6                 &
   -A(4)*(T**4)/12                &
   -A(5)*(T**5)/20+A(6))

gp = Runiv*2*M2*(B(1)*(1-log(T))*T      &
   -B(7)*T                        &
   -B(2)*(T**2)/2                 &
   -B(3)*(T**3)/6                 &
   -B(4)*(T**4)/12                &
   -B(5)*(T**5)/20+B(6))

dg = gp-gr

keq =(101325d0/Runiv/T)*exp(-dg/Runiv/T)
kf = (2.75d16/T)* exp(-59500d0/T)

d1dt= (-1)*M1*(kf)*((rho1/M1)- rho2*rho2/(M2*M2*keq))*(TB1*rho1/M1 + TB2*rho2/M2)

rho1sp = rho1 + dt*d1dt
rho2sp = rhoi - rho1
d1dt= (-1)*M1*(kf)*((rho1sp/M1)- rho2sp*rho2sp/(M2*M2*keq))*(TB1*rho1sp/M1 + TB2*rho2sp/M2)
rho1 = 0.5* rho1sp + 0.5*(rho1 + d1dt*dt )

rho2=rhoi-rho1

!!!!!!!!!!!!!
!!Net energy change = 0
!!!!!!!!!!!!!!

do n = 1,nitermax

if (T<=1000) then
  A=B1h
  B=B2h
elseif (T>1000) then
  A=A1h
  B=A2h
endif

h1 =  (A(1)*T+A(2)*(T**2)/2 + A(3)*(T**3)/3+A(4)*(T**4)/4+ &
       A(5)*(T**5)/5+A(6))*Runiv

e1 = h1- Runiv*T/M1
eng1=rho1*e1

h2 =  (B(1)*T+B(2)*(T**2)/2 + B(3)*(T**3)/3+B(4)*(T**4)/4+ &
       B(5)*(T**5)/5+B(6))*Runiv

e2 = h2- Runiv*T/M2
eng2=rho2*e2

eng=eng1+eng2
deng=eng-engi

!!!!!!!!! Update T to make deng =0

dengdT = (rho1*( (A(1)+A(2)*(T) + A(3)*(T**2)+A(4)*(T**3)+                     &
       A(5)*(T**4)) - 1/M1) + rho2*(B(1)+B(2)*(T)/2 + B(3)*(T**2)+B(4)*(T**3)+ &
       B(5)*(T**4) - 1/M2))*Runiv

T = T - deng/dengdT

if (abs(deng/dengdT) < 10e-6) then

   exit

end if

end do

print*, i,n,time,T,rho1/rhoi,dg

write(2,*) i,n,time,rho1/rhoi,rho2/rhoi,T
if (i.eq.1) res0=abs(d1dt)
res = abs(d1dt)/res0
if ((abs(res)<10e-8)) then
   exit
end if
time = time + dt
end do

close(2)

end


!-----------------------------------------------------------------------
!     SUBROUTINE ELPMPP02 TEST:
!     COMPUTATION OF GEOCENTRIC RECTANGULAR COORDINATES OF THE MOON
!-----------------------------------------------------------------------
!
      implicit        double precision (a-h,o-z)
      character*5     aa(0:1)
      dimension       r(6)
      dimension       dp(4)
      parameter       (dj2000=2451545.0d0)
      data            aa/'LLR','DE405'/
!
      open (10,file='ELPMPP02.TXT')
!
!-----------------------------------------------------------------------
!     COMPUTE LUNAR COORDINATES (POSITIONS ANS VELOCITIES):
!     5 DATES FROM JD 2444239.5 TO 2452239.5,
!     TIME INTERVAL = 2000 DAYS,
!     CONSTANTS FITTED TO LLR OBSERVATIONS.
!-----------------------------------------------------------------------
!
      tj0=2444239.5d0
      dtj=2000.d0
      nda=5
      icor=0
!
      do n=1,nda
!
         t=tj0+(n-1)*dtj-dj2000
!
         call ELPMPP02 (t,11,icor,r,ierr)
!
         if (ierr.ne.0) then
             write (*,*) 'ERREUR ',ierr
             stop
         endif
!
         tdj=t+dj2000
         write (*,1002)  tdj,r
         write (10,1002) tdj,r
!
         call DELAUNY (t,dp)
         write (*,1003) dp
!
      enddo
!
      call SHOW_TERMS ()
!
!-----------------------------------------------------------------------
!     COMPUTE LUNAR COORDINATES (POSITIONS ANS VELOCITIES):
!     5 DATES FROM JD 2500000.5 TO 1700000.5,
!     TIME INTERVAL = -200000 DAYS,
!     CONSTANTS FITTED TO JPL EPHEMERIS DE405.
!-----------------------------------------------------------------------
!
      tj0=2500000.5d0
      dtj=-200000.d0
      nda=5
      icor=1
!
      do n=1,nda
!
         t=tj0+(n-1)*dtj-dj2000
!
         call ELPMPP02 (t,11,icor,r,ierr)
!
         if (ierr.ne.0) then
             write (*,*) 'ERREUR ',ierr
             stop
         endif
!
         tdj=t+dj2000
         write (*,1002)  tdj,r
         write (10,1002) tdj,r
!
         call DELAUNY (t,dp)
         write (*,1003) dp
!
      enddo
!
      stop
!
! --- Formats ----------------------------------------------------------
!
1001  format (/2x,'ELP/MPP02:'
     &        ,2x,'t0: ',f9.1,2x,'nda: ',i5,2x,'icor: ',a/)
1002  format (2x,'JD ',f9.1/
     &        2x,'X = ',f17.7,
     &        2x,'Y = ',f17.7,
     &        2x,'Z = ',f17.7,2x,'km'/
     &        2x,'X''= ',f17.7,
     &        2x,'Y''= ',f17.7,
     &        2x,'Z''= ',f17.7,2x,'km/day')
1003  format (2x,' D:',f25.3/
     &        2x,' F:',f25.3/
     &        2x,' l:',f25.3/
     &        2x,'lp:',f25.3/)
      end
!
!
!
      subroutine ELPMPP02 (tj,lu,icor,xyz,ierr)
!-----------------------------------------------------------------------
!
!     Ref: JCGF0206
!
! --- OBJECT -----------------------------------------------------------
!
!     Computation of the Moon coordinates with ELP/MPP02 lunar theory.
!     Frame: dynamical mean ecliptic and equinox of J2000.
!
! --- INPUT ------------------------------------------------------------
!
!     tj       : Time in days from J2000 (real*8).
!
!     lu       : Logical unit of Moon files (integer).
!
!     icor     : Index of the corrections to the constants (integer).
!
! --- OUTPUT -----------------------------------------------------------
!
!     xyz(6)   : Geocentric rectangular coordinates (real*8).
!                xyz(1) : Position X (km)
!                xyz(2) : Position Y (km)
!                xyz(3) : Position Z (km)
!                xyz(4) : Velocity X' (km/day)
!                xyz(5) : Velocity Y' (km/day)
!                xyz(6) : Velocity Z' (km/day)
!
!     ierr     : Error file index (integer).
!                ierr=0 : no error.
!                ierr=1 : error file.
!
! --- HOW TO USE IT ----------------------------------------------------
!
!     The subroutine ELPMPP02 calls 3 subroutines:
!     INITIAL  : Initialization of the constants of the solution,
!     READFILE : Reading the 6 files containing the ELP/MPP02 series,
!     EVALUATE : Computation of the geocentric coordinates of the Moon.
!
!     The subroutines INITIAL and READFILE are used after the first call
!     to the subroutine ELPMPP02. They are also called each time the
!     index of the corrections is modified. Hence, it is not advisable
!     to change the index during a same run.
!
!     The subroutine ELPMPP02 uses 2 commons:
!     ELPCST : Constants of the solution ELP/MPP02,
!     ELPSER : Series of the solution ELP/MPP02.
!
!     The constants are initialized by INITIAL and used in READFILE and
!     EVALUATE. The series are read by READFILE and used in EVALUATE.
!
!     The subroutine ELPMPP02 sets the names of the 6 files that
!     contain the ELP/MPP02 series (parameter 'filename').
!     These names include the directory where the files are stored.
!     By default, the files are supposed to be stored in the current
!     directory.
!
!     The nominal values of some constants have to be corrected.
!     There are 2 sets of corrections. The corresponding choice is
!     marked by the parameter 'icor' (used in INITIAL).
!     icor=0, the constants are fitted to LLR observations provided
!             from 1970 to 2001; it is the default value;
!     icor=1, the constants are fitted to DE405 ephemeris over one
!             century (1950-1960); the lunar angles W1, W2, W3 receive
!             also additive corrections to the secular coefficients.
!
! --- Declarations -----------------------------------------------------
!
      implicit double precision (a-h,o-z),integer(i-n)
!
      character*40   filename(6)
      dimension      xyz(6)
!
      data           kinit/999/
      save           kinit
!
! --- Names of the ELPMPP02 files --------------------------------------
!
      filename(1)='ELP_MAIN.S1'
      filename(2)='ELP_MAIN.S2'
      filename(3)='ELP_MAIN.S3'
      filename(4)='ELP_PERT.S1'
      filename(5)='ELP_PERT.S2'
      filename(6)='ELP_PERT.S3'
!
! --- Initializing of constants and Reading the files-------------------
!
      if (icor.ne.kinit) then
         call INITIAL (icor)
         call READFILE (lu,filename,ierr)
         if (ierr.ne.0) return
         kinit=icor
      endif
!
! --- Computation of the geocentric coordinates of the Moon ------------
!
      call EVALUATE (tj,xyz)
!
      return
      end
!
!
      subroutine DELAUNY (tj,dp)
!
      implicit double precision (a-h,o-z),integer(i-n)
!
      common/elpcst/  w(3,0:4),eart(0:4),peri(0:4),zeta(0:4),del(4,0:4),
     &                p(8,0:4),delnu,dele,delg,delnp,delep,dtasm,am,
     &                p1,p2,p3,p4,p5,q1,q2,q3,q4,q5
      dimension       dp(4)
!
      tc = tj / 36525.0
      tp = 1.d0
      do i=1,4
        dp(i) = 0.d0
      enddo
      do k=0,4
        do i=1,4
          dp(i)=dp(i) + del(i,k) * tp
        enddo
        tp = tp * tc
      enddo
!
      return
      end
!
!
      subroutine INITIAL (icor)
!-----------------------------------------------------------------------
!
!     Ref: JCGF0206
!
! --- OBJECT -----------------------------------------------------------
!
!     Initialization of the constants and parameters used for the
!     evaluation of the ELP/MPP02 series.
!
! --- INPUT ------------------------------------------------------------
!
!     icor     : Index of the corrections to the constants (integer).
!
! --- OUTPUT -----------------------------------------------------------
!
!     elpcst   : Set of the constants of ELPMPP02 solution (common).
!
! --- REMARKS ----------------------------------------------------------
!
!     The nominal values of some constants have to be corrected.
!     There are 2 sets of corrections. The corresponding choice is
!     marked by the parameter 'icor' (used in INITIAL).
!     icor=0, the constants are fitted to LLR observations provided
!             from 1970 to 2001; it is the default value;
!     icor=1, the constants are fitted to DE405 ephemeris over one
!             century (1950-1960); the lunar angles W1, W2, W3 receive
!             also additive corrections to the secular coefficients.
!
! --- NOTATIONS --------------------------------------------------------
!
!     Moon elements (polynomials coefficients until order 4):
!     w(1,0:4)  : mean longitude of the Moon                        (W1)
!     w(2,0:4)  : mean longitude of the lunar perigee               (W2)
!     w(3,0:4)  : mean longitude of the lunar ascending node        (W3)
!     zeta(0:4) : mean longitude of the Moon + precession        (W1+pt)
!                 p is the precession rate and t is the time
!
!     Earth-Moon (EMB) elements (polynomials coefficients until order 4):
!     eart(0:4) : mean longitude of EMB                             (Te)
!     peri(0:4) : mean longitude of the perihelion of EMB          (Pip)
!
!     Delaunay arguments (polynomials coefficients until order 4):
!     del(1,0:4): D  =  W1 - Te + 180 degrees                        (D)
!     del(2,0:4): F  =  W1 - W3                                      (F)
!     del(3,0:4): l  =  W1 - W2   mean anomaly of the Moon           (l)
!     del(4,0:4): l' =  Te - Pip  mean anomaly of EMB               (l')
!
!     Planetary arguments (mean longitudes at J2000 and mean motions):
!     p(1,0:1)  : mean longitude of Mercury
!     p(2,0:1)  : mean longitude of Venus
!     p(3,0:1)  : mean longitude of EMB (eart(0:1))
!     p(4,0:1)  : mean longitude of Mars
!     p(5,0:1)  : mean longitude of Jupiter
!     p(6,0:1)  : mean longitude of Saturn
!     p(7,0:1)  : mean longitude of Uranus
!     p(8,0:1)  : mean longitude of Neptune
!
!     Moon constants:
!     nu        : mean motion of the Moon (W1(1,1))                 (Nu)
!     g         : half coefficient of sin(F) in latitude         (Gamma)
!     e         : half coefficient of sin(l) in longitude            (E)
!     np        : mean motion of EMB (eart(1))                      (n')
!     ep        : eccentricity of EMB                               (e')
!     alpha     : Ratio of the semi-major axis (Moon / EMB)
!     am        : Ratio of the mean motions (EMB / Moon)
!     dtasm     : (2*alpha) / (3*am)
!
!     Corrections to the constants Nu, Gamma, E, n', e':
!     delnu     : to the mean motion of the Moon
!     delg      : to the half coefficient of sin(F) in latitude
!     dele      : to the half coefficient of sin(l) in longitude
!     delnp     : to the mean motion of EMB
!     delep     : to the eccentricity of EMB
!
!     Precession of the longitude of the ascending node of the mean
!     ecliptic of date on fixed ecliptic J2000:
!     pi(i=1,5) : sine coefficients
!     qi(i=1,5) : cosine coefficients
!
! --- Declarations -----------------------------------------------------
!
      implicit double precision (a-h,o-z),integer(i-n)
!
      parameter       (cpi=3.141592653589793d0)
      parameter       (rad=648000.d0/cpi,deg=cpi/180.d0)
!
      common/elpcst/  w(3,0:4),eart(0:4),peri(0:4),zeta(0:4),del(4,0:4),
     &                p(8,0:4),delnu,dele,delg,delnp,delep,dtasm,am,
     &                p1,p2,p3,p4,p5,q1,q2,q3,q4,q5
!
      dimension       bp(5,2)
      data bp/        +0.311079095d00, -0.4482398d-2,
     &                -0.110248500d-2, +0.1056062d-2, +0.50928d-4,
     &                -0.103837907d00, +0.6682870d-3,
     &                -0.129807200d-2, -0.1780280d-3, -0.37342d-4/
!
! --- Function for the conversion : sexagesimal degrees -> radians -----
!
      DMS(ideg,imin,sec)=(ideg+imin/60.d0+sec/3600.d0)*deg
!
! --- Value of the correction to the constant of precession ------------
!
      Dprec=-0.29965d0                                  !***** IAU 2000A
!
! --- Constants for the evaluation of the partial derivatives ----------
!
      am     =  0.074801329d0
      alpha  =  0.002571881d0
      dtasm  =  (2.d0*alpha)/(3.d0*am)
      xa     =  (2.d0*alpha)/3.d0
!
! --- Corrections to constants -----------------------------------------
!
      k=icor
      if (k.ne.1) k=0
!
!     Values of the corrections to the constants fitted to LLR.
!     Fit 13-05-02 (2 iterations) except Phi and eps w2_1 et w3_1
!
      if (k.eq.0) then
!
         Dw1_0   = -0.10525d0
         Dw2_0   =  0.16826d0
         Dw3_0   = -0.10760d0
         Deart_0 = -0.04012d0
         Dperi   = -0.04854d0
         Dw1_1   = -0.32311d0
         Dgam    =  0.00069d0
         De      = +0.00005d0
         Deart_1 =  0.01442d0
         Dep     =  0.00226d0
         Dw2_1   =  0.08017d0
         Dw3_1   = -0.04317d0
         Dw1_2   = -0.03794d0
!
      else
!
!     Values of the corrections to the constants fitted to DE405
!     over the time interval (1950-2060)
!
         Dw1_0   = -0.07008d0
         Dw2_0   =  0.20794d0
         Dw3_0   = -0.07215d0
         Deart_0 = -0.00033d0
         Dperi   = -0.00749d0
         Dw1_1   = -0.35106d0
         Dgam    =  0.00085d0
         De      = -0.00006d0
         Deart_1 =  0.00732d0
         Dep     =  0.00224d0
         Dw2_1   =  0.08017d0
         Dw3_1   = -0.04317d0
         Dw1_2   = -0.03743d0
!
      endif
!
! --- Fundamental arguments (Moon and EMB) -----------------------------
!
      w(1,0) = DMS(218,18,59.95571d0+Dw1_0)              !***** ELP
      w(1,1) = (1732559343.73604d0+Dw1_1)/rad            !***** ELP
      w(1,2) = (        -6.8084d0 +Dw1_2)/rad            !***** DE405
      w(1,3) =          0.66040d-2/rad                   !***** ELP
      w(1,4) =         -0.31690d-4/rad                   !***** ELP
!
      w(2,0) = DMS( 83,21,11.67475d0+Dw2_0)              !***** ELP
      w(2,1) = (  14643420.3171d0 +Dw2_1)/rad            !***** DE405
      w(2,2) = (       -38.2631d0)/rad                   !***** DE405
      w(2,3) =         -0.45047d-1/rad                   !***** ELP
      w(2,4) =          0.21301d-3/rad                   !***** ELP
!
      w(3,0) = DMS(125, 2,40.39816d0+Dw3_0)              !***** ELP
      w(3,1) = (  -6967919.5383d0 +Dw3_1)/rad            !***** DE405
      w(3,2) = (         6.3590d0)/rad                   !***** DE405
      w(3,3) =          0.76250d-2/rad                   !***** ELP
      w(3,4) =         -0.35860d-4/rad                   !***** ELP
!
      eart(0)= DMS(100,27,59.13885d0+Deart_0)            !***** VSOP2000
      eart(1)= (129597742.29300d0 +Deart_1)/rad          !***** VSOP2000
      eart(2)=         -0.020200d0/rad                   !***** ELP
      eart(3)=          0.90000d-5/rad                   !***** ELP
      eart(4)=          0.15000d-6/rad                   !***** ELP

      peri(0)= DMS(102,56,14.45766d0+Dperi)              !***** VSOP2000
      peri(1)=       1161.24342d0/rad                    !***** VSOP2000
      peri(2)=          0.529265d0/rad                   !***** VSOP2000
      peri(3)=         -0.11814d-3/rad                   !***** VSOP2000
      peri(4)=          0.11379d-4/rad                   !***** VSOP2000
!
! --- Corrections to the secular terms of Moon angles ------------------
!
      if (icor.eq.1) then
         w(1,3) = w(1,3) -0.00018865d0/rad
         w(1,4) = w(1,4) -0.00001024d0/rad
         w(2,2) = w(2,2) +0.00470602d0/rad
         w(2,3) = w(2,3) -0.00025213d0/rad
         w(3,2) = w(3,2) -0.00261070d0/rad
         w(3,3) = w(3,3) -0.00010712d0/rad
      endif
!
! --- Corrections to the mean motions of the Moon angles W2 and W3 -----
!     infered from the modifications of the constants
!
      x2     =   w(2,1)/w(1,1)
      x3     =   w(3,1)/w(1,1)
      y2     =   am*bp(1,1)+xa*bp(5,1)
      y3     =   am*bp(1,2)+xa*bp(5,2)
!
      d21    =   x2-y2
      d22    =   w(1,1)*bp(2,1)
      d23    =   w(1,1)*bp(3,1)
      d24    =   w(1,1)*bp(4,1)
      d25    =   y2/am
!
      d31    =   x3-y3
      d32    =   w(1,1)*bp(2,2)
      d33    =   w(1,1)*bp(3,2)
      d34    =   w(1,1)*bp(4,2)
      d35    =   y3/am
!
      Cw2_1  =  d21*Dw1_1+d25*Deart_1+d22*Dgam+d23*De+d24*Dep
      Cw3_1  =  d31*Dw1_1+d35*Deart_1+d32*Dgam+d33*De+d34*Dep
!
      w(2,1) =  w(2,1)+Cw2_1/rad
      w(3,1) =  w(3,1)+Cw3_1/rad
!
! --- Arguments of Delaunay --------------------------------------------
!
      do i=0,4
         del(1,i) = w(1,i)-eart(i)                             !***** D
         del(2,i) = w(1,i)-w(3,i)                              !***** F
         del(3,i) = w(1,i)-w(2,i)                              !***** l
         del(4,i) = eart(i)-peri(i)                            !***** l'
      end do
      del(1,0) = del(1,0) + cpi
!
! --- Planetary arguments (mean longitudes and mean motions) -----------
!
      p(1,0) = DMS(252,15, 3.216919d0)                   !***** VSOP2000
      p(2,0) = DMS(181,58,44.758419d0)                   !***** VSOP2000
      p(3,0) = DMS(100,27,59.138850d0)                   !***** VSOP2000
      p(4,0) = DMS(355,26, 3.642778d0)                   !***** VSOP2000
      p(5,0) = DMS( 34,21, 5.379392d0)                   !***** VSOP2000
      p(6,0) = DMS( 50, 4,38.902495d0)                   !***** VSOP2000
      p(7,0) = DMS(314, 3, 4.354234d0)                   !***** VSOP2000
      p(8,0) = DMS(304,20,56.808371d0)                   !***** VSOP2000
!
      p(1,1) = 538101628.66888d0/rad                     !***** VSOP2000
      p(2,1) = 210664136.45777d0/rad                     !***** VSOP2000
      p(3,1) = 129597742.29300d0/rad                     !***** VSOP2000
      p(4,1) =  68905077.65936d0/rad                     !***** VSOP2000
      p(5,1) =  10925660.57335d0/rad                     !***** VSOP2000
      p(6,1) =   4399609.33632d0/rad                     !***** VSOP2000
      p(7,1) =   1542482.57845d0/rad                     !***** VSOP2000
      p(8,1) =    786547.89700d0/rad                     !***** VSOP2000
!
      do i=1,8
      do j=2,4
         p(i,j)=0.d0
      enddo
      enddo
!
! --- Zeta : Mean longitude W1 + Rate of the precession ----------------
!
      zeta(0)= w(1,0)
      zeta(1)= w(1,1) + (5029.0966d0+Dprec)/rad
      zeta(2)= w(1,2)
      zeta(3)= w(1,3)
      zeta(4)= w(1,4)
!
! --- Corrections to the parameters: Nu, E, Gamma, n' et e' ------------
!
      delnu  = (+0.55604d0+Dw1_1)/rad/w(1,1)                  !***** ELP
      dele   = (+0.01789d0+De)/rad                            !***** ELP
      delg   = (-0.08066d0+Dgam)/rad                          !***** ELP
      delnp  = (-0.06424d0+Deart_1)/rad/w(1,1)                !***** ELP
      delep  = (-0.12879d0+Dep)/rad                           !***** ELP
!
! --- Precession coefficients for P and Q (Laskar, 1986) ---------------
!
      p1 =  0.10180391d-04
      p2 =  0.47020439d-06
      p3 = -0.5417367d-09
      p4 = -0.2507948d-11
      p5 =  0.463486d-14
!
      q1 = -0.113469002d-03
      q2 =  0.12372674d-06
      q3 =  0.1265417d-08
      q4 = -0.1371808d-11
      q5 = -0.320334d-14
!
      end subroutine INITIAL
!
!
!
      subroutine READFILE (lu,filename,ierr)
!-----------------------------------------------------------------------
!
!     Ref: JCGF0206
!
! --- OBJECT -----------------------------------------------------------
!
!     Reading the 6 files containing the ELP/MPP02 series
!
! --- INPUT ------------------------------------------------------------
!
!     lu       : Logical unit of the files ELP/MPP02 (integer).
!     filename : Names of the files ELP/MPP02 (character*40).
!     elpcst   : Set of the constants of ELP/MPP02 solution (common).
!
! --- OUTPUT -----------------------------------------------------------
!
!     elpser   : Series of the ELP/MPP02 solution (common).
!     ierr     : Error file index (integer).
!                ierr=0 : no error.
!                ierr=1 : error file.
!
! --- Declarations -----------------------------------------------------
!
      implicit double precision (a-h,o-z),integer(i-n)
!
      character*40    filename(6)
      logical         fexist
!
      parameter       (max1=2645,max2=33256)
      parameter       (cpi=3.141592653589793d0)
      parameter       (pis2=cpi/2.d0,dpi=2.d0*cpi)
!
      dimension       b(5),ilu(4),ipla(11),ifi(16)
!
      common/elpcst/  w(3,0:4),eart(0:4),peri(0:4),zeta(0:4),del(4,0:4),
     &                p(8,0:4),delnu,dele,delg,delnp,delep,dtasm,am,
     &                p1,p2,p3,p4,p5,q1,q2,q3,q4,q5
!
      common/elpser/  cmpb(max1),fmpb(0:4,max1),nmpb(3,3),
     &                cper(max2),fper(0:4,max2),nper(3,0:3,3)
!
! --- Check up the files -----------------------------------------------
!
      ierr=1
      do i=1,6
         inquire (file=filename(i),exist=fexist)
         if (.not.fexist) return
      enddo
!
! --- Reading Main Problem series --------------------------------------
!
      ir=0
      do iv=1,3
      do k=1,3
         nmpb(iv,k)=0
      enddo
      enddo
!
      do iv=1,3
         open (lu,file=filename(iv),status='old',iostat=nerr)
         if (nerr.ne.0) return
         read (lu,1001,iostat=nerr,end=100) nmpb(iv,1)
         if (nerr.ne.0) return
         nmpb(iv,2)=ir+1
         nmpb(iv,3)=nmpb(iv,1)+nmpb(iv,2)-1
         do n=1,nmpb(iv,1)
            read (lu,1002,iostat=nerr,end=100) ilu,a,b
            if (nerr.ne.0) return
            ir=ir+1
            tgv=b(1)+dtasm*b(5)
            if (iv.eq.3) a=a-2.d0*a*delnu/3.d0
            cmpb(ir) = a+tgv*(delnp-am*delnu)
     &               + b(2)*delg + b(3)*dele + b(4)*delep
            do k=0,4
               fmpb(k,ir)=0.d0
               do i=1,4
                  fmpb(k,ir)=fmpb(k,ir)+ilu(i)*del(i,k)
               enddo
            enddo
            if (iv.eq.3) fmpb(0,ir)=fmpb(0,ir)+pis2
         enddo
         close (lu)
      enddo
!
! --- Reading Perturbations series -------------------------------------
!
      ir=0
      do iv=1,3
      do it=0,3
      do k=1,3
         nper(iv,it,k)=0
      enddo
      enddo
      enddo
!
      do iv=1,3
         open (lu,file=filename(iv+3),status='old',iostat=nerr)
         if (nerr.ne.0) return
         do it=0,3
            read (lu,1003,iostat=nerr,end=100) nper(iv,it,1),ipt
            if (nerr.ne.0) return
            nper(iv,it,2)=ir+1
            nper(iv,it,3)=nper(iv,it,1)+nper(iv,it,2)-1
            if (nper(iv,it,1).eq.0) cycle
            do n=1,nper(iv,it,1)
               read (lu,1004,iostat=nerr,end=100) icount,s,c,ifi
               if (nerr.ne.0) return
               ir=ir+1
               cper(ir)=sqrt(c*c+s*s)
               pha=atan2(c,s)
               if (pha.lt.0.d0) pha=pha+dpi
               do k=0,4
                  fper(k,ir)=0.d0
                  if (k.eq.0) fper(k,ir)=pha
                  do i=1,4
                     fper(k,ir)=fper(k,ir)+ifi(i)*del(i,k)
                  enddo
                  do i=5,12
                     fper(k,ir)=fper(k,ir)+ifi(i)*p(i-4,k)
                  enddo
                  fper(k,ir)=fper(k,ir)+ifi(13)*zeta(k)
               enddo
            enddo
         enddo
         close (lu)
      enddo
!
! --- Exit -------------------------------------------------------------
!
      ierr=0
      return
!
! --- File error -------------------------------------------------------
!
100   continue
      ierr=1
      return
!
! --- Formats ----------------------------------------------------------
!
1001  format (25x,i10)
1002  format (4i3,2x,f13.5,5f12.2)
1003  format (25x,2i10)
1004  format(i5,2d20.13,16i3)
!
      end
!
!
      subroutine SHOW_TERMS ()
!-----------------------------------------------------------------------
!
! --- OBJECT -----------------------------------------------------------
!
!     Show the parameters needed to compute the moon longitude
!
! --- Declarations -----------------------------------------------------
!
      implicit double precision (a-h,o-z),integer(i-n)
!
      parameter       (max1=2645,max2=33256)
      parameter       (xmin=10.0)
!
      common/elpcst/  w(3,0:4),eart(0:4),peri(0:4),zeta(0:4),del(4,0:4),
     &                p(8,0:4),delnu,dele,delg,delnp,delep,dtasm,am,
     &                p1,p2,p3,p4,p5,q1,q2,q3,q4,q5
!
      common/elpser/  cmpb(max1),fmpb(0:4,max1),nmpb(3,3),
     &                cper(max2),fper(0:4,max2),nper(3,0:3,3)
!
! --- Printing of the series for longitude, with no substitution of time -----
!
      lu=12
      open (lu, file='PARAMS.TXT')
!
!     Variable iv=1 : Longitude
!     Variable iv=2 : Latitude
!     Variable iv=3 : Distance
!
      do iv=1,3
!
! ------ Main Problem series -------------------------------------------
!
         do n=nmpb(iv,2),nmpb(iv,3)
            if (xmin.le.abs(cmpb(n))) then
              write (lu,1001) iv, n, cmpb(n), fmpb(0,n),
     &          fmpb(1,n), fmpb(2,n), fmpb(3,n), fmpb(4,n)
            endif
         enddo
!
! ------ Perturbations series  -----------------------------------------
!
         do it=0,3
            do n=nper(iv,it,2),nper(iv,it,3)
               if (xmin.le.abs(cper(n))) then
                 write (lu,1002) iv, it, n, cper(n), fper(0,n),
     &             fper(1,n), fper(2,n), fper(3,n), fper(4,n)
               endif
            enddo
         enddo
      enddo
!
! ------ Base Longitude and adjustments --------------------------
!
      write(lu,1003) 'W', w(1,0), w(1,1), w(1,2), w(1,3), w(1,4)
      write(lu,1003) 'P', p1, p2, p3, p4, p5
      write(lu,1003) 'Q', q1, q2, q3, q4, q5
!
      close(lu)
!
      return
!
! --- Formats ----------------------------------------------------------
!
1001  format ('M', i2,     i5, f17.5, f17.5, f17.5, f17.5, f17.5, f17.5)
1002  format ('P', i2, i2, i7, f17.5, f17.5, f17.5, f17.5, f17.5, f17.5)
1003  format (1a,          f17.5, f17.5, f17.5, f17.5, f17.5       )
!
      end
!
!
      subroutine EVALUATE (tj,xyz)
!-----------------------------------------------------------------------
!
!     Ref: JCGF0206
!
! --- OBJECT -----------------------------------------------------------
!
!     Evaluation of the series ELP/MPP02.
!     Computation of the geocentric rectangular coordinates of the Moon
!     Frame: dynamical mean ecliptic and equinox of J2000.
!
! --- INPUT ------------------------------------------------------------
!
!     tj       : Time in days from J2000 (real*8).
!     elpcst   : Set of the constants of ELP/MPP02 solution (common).
!     elpser   : Series of the ELP/MPP02 solution (common).
!
! --- OUTPUT -----------------------------------------------------------
!
!     xyz(6)   : Geocentric rectangular coordinates (real*8).
!                xyz(1) : Position X (km)
!                xyz(2) : Position Y (km)
!                xyz(3) : Position Z (km)
!                xyz(4) : Velocity X' (km/day)
!                xyz(5) : Velocity Y' (km/day)
!                xyz(6) : Velocity Z' (km/day)
!
! --- Declarations -----------------------------------------------------
!
      implicit double precision (a-h,o-z),integer(i-n)
!
      dimension       t(0:4),xyz(6),v(6)
!
      parameter       (dj2000=2451545.0d0)
      parameter       (max1=2645,max2=33256)
      parameter       (cpi=3.141592653589793d0)
      parameter       (a405=384747.9613701725d0)
      parameter       (aelp=384747.980674318d0)
      parameter       (rad=648000.d0/cpi,sc=36525.d0)
!
      common/elpcst/  w(3,0:4),eart(0:4),peri(0:4),zeta(0:4),del(4,0:4),
     &                p(8,0:4),delnu,dele,delg,delnp,delep,dtasm,am,
     &                p1,p2,p3,p4,p5,q1,q2,q3,q4,q5
!
      common/elpser/  cmpb(max1),fmpb(0:4,max1),nmpb(3,3),
     &                cper(max2),fper(0:4,max2),nper(3,0:3,3)
!
! --- Initialization of time powers ------------------------------------

      t(0)=1.d0
      t(1)=tj/sc
      t(2)=t(1)*t(1)
      t(3)=t(2)*t(1)
      t(4)=t(3)*t(1)
!
! --- Evaluation of the series: substitution of time in the series -----
!     Variable iv=1 : Longitude
!     Variable iv=2 : Latitude
!     Variable iv=3 : Distance
!
      do iv=1,3
!
         v(iv)=0.d0
         v(iv+3)=0.d0
!
! ------ Main Problem series -------------------------------------------
!
         do n=nmpb(iv,2),nmpb(iv,3)
            x=cmpb(n)
            y=fmpb(0,n)
            yp=0.d0
            do k=1,4
               y=y+fmpb(k,n)*t(k)
               yp=yp+k*fmpb(k,n)*t(k-1)
            enddo
            v(iv)=v(iv)+x*sin(y)
            v(iv+3)=v(iv+3)+x*yp*cos(y)
         enddo
!
! ------ Perturbations series  -----------------------------------------
!
         do it=0,3
            do n=nper(iv,it,2),nper(iv,it,3)
               x=cper(n)
               y=fper(0,n)
               xp=0.d0
               yp=0.d0
               if (it.ne.0) xp=it*x*t(it-1)
               do k=1,4
                  y=y+fper(k,n)*t(k)
                  yp=yp+k*fper(k,n)*t(k-1)
               enddo
               v(iv)=v(iv)+x*t(it)*sin(y)
               v(iv+3)=v(iv+3)+xp*sin(y)+x*t(it)*yp*cos(y)
            enddo
         enddo
!
      enddo
!
! --- Computation of the rectangular coordinates (Epoch J2000) ---------
!
      v(1)   = v(1)/rad
     &       + w(1,0)+w(1,1)*t(1)+w(1,2)*t(2)+w(1,3)*t(3)+w(1,4)*t(4)
      v(2)   = v(2)/rad
      v(3)   = v(3)*a405/aelp
      v(4)   = v(4)/rad
     &       + w(1,1)+2.d0*w(1,2)*t(1)+3.d0*w(1,3)*t(2)+4.d0*w(1,4)*t(3)
      v(5)   = v(5)/rad
!
      clamb  = cos(v(1))
      slamb  = sin(v(1))
      cbeta  = cos(v(2))
      sbeta  = sin(v(2))
      cw     = v(3)*cbeta
      sw     = v(3)*sbeta
!
      x1     = cw*clamb
      x2     = cw*slamb
      x3     = sw
      xp1    = (v(6)*cbeta-v(5)*sw)*clamb-v(4)*x2
      xp2    = (v(6)*cbeta-v(5)*sw)*slamb+v(4)*x1
      xp3    = v(6)*sbeta+v(5)*cw
!
      pw     = (p1+p2*t(1)+p3*t(2)+p4*t(3)+p5*t(4))*t(1)
      qw     = (q1+q2*t(1)+q3*t(2)+q4*t(3)+q5*t(4))*t(1)
      ra     = 2.d0*sqrt(1-pw*pw-qw*qw)
      pwqw   = 2.d0*pw*qw
      pw2    = 1.d0-2.d0*pw*pw
      qw2    = 1.d0-2.d0*qw*qw
      pwra   = pw*ra
      qwra   = qw*ra
!
      xyz(1) = pw2*x1+pwqw*x2+pwra*x3
      xyz(2) = pwqw*x1+qw2*x2-qwra*x3
      xyz(3) = -pwra*x1+qwra*x2+(pw2+qw2-1)*x3
!
      ppw    = p1+(2.d0*p2+3.d0*p3*t(1)+4.d0*p4*t(2)+5.d0*p5*t(3))*t(1)
      qpw    = q1+(2.d0*q2+3.d0*q3*t(1)+4.d0*q4*t(2)+5.d0*q5*t(3))*t(1)
      ppw2   = -4.d0*pw*ppw
      qpw2   = -4.d0*qw*qpw
      ppwqpw = 2.d0*(ppw*qw+pw*qpw)
      rap    = (ppw2+qpw2)/ra
      ppwra  = ppw*ra+pw*rap
      qpwra  = qpw*ra+qw*rap
!
      xyz(4) = (pw2*xp1+pwqw*xp2+pwra*xp3
     &       + ppw2*x1+ppwqpw*x2+ppwra*x3)/sc
      xyz(5) = (pwqw*xp1+qw2*xp2-qwra*xp3
     &       + ppwqpw*x1+qpw2*x2-qpwra*x3)/sc
      xyz(6) = (-pwra*xp1+qwra*xp2+(pw2+qw2-1.d0)*xp3
     &       - ppwra*x1+qpwra*x2+(ppw2+qpw2)*x3)/sc
!
      return
      end


c     ============================================
      subroutine setaux(maxmx,maxmy,mbc,mx,my,xlower,ylower,dx,dy,
     &                  maux,aux)
c     ============================================
c
c     # set auxiliary arrays
c     # variable coefficient acoustics
c     #  aux(i,j,1) = density rho in (i,j) cell
c     #  aux(i,j,2) = lambda in (i,j) cell
c     #  aux(i,j,3) = mu in (i,j) cell
c     #  aux(i,j,4) = cp in (i,j) cell
c     #  aux(i,j,5) = cs in (i,j) cell
c
c     # Piecewise constant medium
c     # Material parameters are set in setprob.f

c
c
      implicit double precision (a-h,o-z)
      dimension aux(1-mbc:maxmx+mbc,1-mbc:maxmy+mbc, 5)
      common /comaux/ rho1,amu1,alam1,rho2,amu2,alam2
c

      do 30 j=1-mbc,my+mbc
       do 20 i=1-mbc,mx+mbc
          xl = xlower + (i-1.0d0)*dx
          yl = ylower + (j-1.0d0)*dy
          call cellave(xl,yl,dx,dy,w1)
          w2 = 1.d0 - w1

          aux(i,j,1) = w1*rho1 + w2*rho2
          aux(i,j,2) = w1*alam1 + w2*alam2
          aux(i,j,3) = w1*amu1 + w2*amu2
          bulk       = aux(i,j,2) + 2.d0*aux(i,j,3)
          aux(i,j,4) = dsqrt(bulk/aux(i,j,1))
          aux(i,j,5) = dsqrt(aux(i,j,3)/aux(i,j,1))

   20     continue
   30    continue

       return
       end


      SUBROUTINE RES (T, U, UPRIME, CJ, DELTA, IRES, RPAR, IPAR,
     *                SENPARA)
C
C This is the user-supplied RES subroutine for this example.
C It computes the residuals for the 2-D discretized heat equation,
C with zero boundary values.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION U(*), UPRIME(*), DELTA(*), RPAR(*), IPAR(*),
     *          SENPARA(*)
C
C Set problem constants using IPAR and RPAR.
      NEQ = IPAR(3)
      M = IPAR(4)
      COEFF = RPAR(2)
      M2 = M + 2
C
C Load U into DELTA, in order to set boundary values.
      DO 10 I = 1,NEQ
 10     DELTA(I) = U(I)
C
C Loop over interior points, and load residual values.
      DO 30 K = 1,M
        IOFF = M2*K
        DO 20 J = 1,M
          I = IOFF + J + 1
          TEMX = SENPARA(1)*(U(I-1)  + U(I+1)  - 2.0d0*u(i))
          TEMY = SENPARA(2)*(U(I-M2) + U(I+M2) - 2.0d0*u(i))
          DELTA(I) = UPRIME(I) - (TEMX + TEMY)*COEFF
 20       CONTINUE
 30     CONTINUE
C
      RETURN
C------------  End of Subroutine RESH  ---------------------------------
      END


module domeasures

  use fsystem
  use triangulation

  implicit none

contains

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

!<subroutine>

  subroutine GetMeasure(Nel,Done,Dmeasure)

  !<description>
  ! This subroutine is used in the grid adaption for measuring the
  ! domain area
  !</description>

  !<input>
  ! Number of elements
  integer, intent(IN) :: Nel
  ! Array of element areas
  real(DP), dimension(:), intent (IN) :: Done
  !</input>

  !<output>
  ! area of the domain
  real(DP), intent(OUT) :: Dmeasure
  !</output>

!</subroutine>

  ! local variables
  integer(I32) :: i

    Dmeasure=0D0
    do i=1,Nel
      Dmeasure=Dmeasure+Done(i)
    end do

  end subroutine GetMeasure

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

!<subroutine>

  subroutine GetAvgSizeElems(rtriangulation,Kcount,Dsize,Dsizem,Dratio)

!<description>
  ! Calculates the average size of elements surrounding a node and
  ! normalize it such that 1d0 is the max. over the whole vector dsize
!</description>

 include 'cout.inc'

!<input>
    type (t_triangulation), intent(IN) :: rtriangulation
!</input>

!<output>
  ! area of the domain
  real(DP), intent(OUT), dimension(:) :: Dratio,Dsizem,Dsize
  integer(I32), intent(OUT), dimension(:):: Kcount
!</output>

!</subroutine>

  ! local variables
  real(DP), dimension(:,:), pointer :: p_Dcorvg
  integer(I32), dimension(:,:), pointer :: p_Kvert
  integer(I32), dimension(:,:), pointer :: p_Kadj
  integer(I32) :: iel, ivt, ive, jel
  real(DP) :: dax, day, dnx, dny, dnrmn, dpx, dpy, dist, dist2
  real(DP) :: dmaxs, dmins, dquot

    call storage_getbase_int2D(rtriangulation%h_IverticesAtElement,p_Kvert)
    call storage_getbase_double2D(rtriangulation%h_DcornerCoordinates,p_Dcorvg)
    call storage_getbase_int2D(rtriangulation%h_IneighboursAtElement,p_Kadj)

    ! Initialise the arrays with 0
    call lalg_vectorClearDble (Dsize)
    call lalg_vectorClearInt (Kcount)

    do iel=1,rtriangulation%NEL

      ! Get first point in quad-element
      dax=p_Dcorvg(1,p_Kvert(1,iel))
      day=p_Dcorvg(2,p_Kvert(1,iel))

      ! Get 3rd point, build normal vector (DNX,DNY) to the diagonal of the
      ! element, normalise it
      dnx= p_Dcorvg(2,p_Kvert(3,iel))-day
      dny=-p_Dcorvg(1,p_Kvert(3,iel))+dax
      dnrmn=DSQRT(dnx*dnx+dny*dny)
      dnx=dnx/dnrmn
      dny=dny/dnrmn

      ! triangle 1,2,3
      dpx=p_dcorvg(1,p_kvert(2,iel))
      dpy=p_dcorvg(2,p_kvert(2,iel))
      dist=abs(dnx*dpx+dny*dpy-dnx*dax-dny*day)

      ! triangle 1,3,4
      dpx=p_dcorvg(1,p_kvert(4,iel))
      dpy=p_dcorvg(2,p_kvert(4,iel))
      dist2=abs(dnx*dpx+dny*dpy-dnx*dax-dny*day)

      ! Calculate size of the element
      Dsizem(iel)=0.5d0*dnrmn*(dist+dist2)

      ! Add the area information to each vertex, building an array with
      ! the sum of areas meeting in a vertex

      Dsize(p_Kvert(1,iel))=Dsize(p_Kvert(1,iel))+0.5d0*dnrmn*(dist+dist2)
      Dsize(p_Kvert(2,iel))=Dsize(p_Kvert(2,iel))+0.5d0*dnrmn*(dist+dist2)
      Dsize(p_Kvert(3,iel))=Dsize(p_Kvert(3,iel))+0.5d0*dnrmn*(dist+dist2)
      Dsize(p_Kvert(4,iel))=Dsize(p_Kvert(4,iel))+0.5d0*dnrmn*(dist+dist2)
      Kcount(p_Kvert(1,iel))=Kcount(p_Kvert(1,iel))+1
      Kcount(p_Kvert(2,iel))=Kcount(p_Kvert(2,iel))+1
      Kcount(p_Kvert(3,iel))=Kcount(p_Kvert(3,iel))+1
      Kcount(p_Kvert(4,iel))=Kcount(p_Kvert(4,iel))+1

    end do

    ! Build the average size of the elements around each vertex:

    ! Divide the summed area by the number of elements meeting in a vertex
    ! and normalise it with the maximum area.

    dmaxs=0d0
    dmins=1d0
    do ivt=1,rtriangulation%NVT
      Dsize(ivt)=Dsize(ivt)/dble(Kcount(ivt))
      dmaxs=max(dmaxs,Dsize(ivt))
      dmins=min(dmins,Dsize(ivt))
    end do

    do ivt=1,rtriangulation%NVT
      Dsize(ivt)=Dsize(ivt)/dmaxs
    end do

    ! Build the vector with the ratio between the area of each element
    ! and its surrounding elements

    do iel=1,rtriangulation%NEL
      Dratio(iel)=0d0
      do ive=1,4
        jel=p_Kadj(ive,iel)
        if (jel.ne.0) then
          ! ratio between area of current and its neighbour element
          dquot=Dsizem(iel)/Dsizem(jel)
          if (dquot.lt.1d0) dquot=1d0/dquot
          ! find the maximum ratio
          if (dquot.gt.Dratio(iel)) Dratio(iel)=dquot
        end if
      end do
    end do

  end subroutine GetAvgSizeElems

end module


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Spherepack                            *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
submodule(gradient_routines) invert_gradient_gaussian_grid

contains

    !     subroutine igradgc(nlat, nlon, isym, nt, sf, isf, jsf, br, bi, mdb, ndb, &
    !                        wshsgc, ierror)
    !
    !     let br, bi, cr, ci be the vector spherical harmonic coefficients
    !     precomputed by vhagc for a vector field (v, w).  let (v', w') be
    !     the irrotational component of (v, w) (i.e., (v', w') is generated
    !     by assuming cr, ci are zero and synthesizing br, bi with vhsgs).
    !     then subroutine igradgc computes a scalar field sf such that
    !
    !            gradient(sf) = (v', w').
    !
    !     i.e.,
    !
    !            v'(i, j) = d(sf(i, j))/dtheta          (colatitudinal component of
    !                                                 the gradient)
    !     and
    !
    !            w'(i, j) = 1/sint*d(sf(i, j))/dlambda  (east longitudinal component
    !                                                 of the gradient)
    !
    !     at the gaussian colatitude theta(i) (see nlat as input parameter)
    !     and longitude lambda(j) = (j-1)*2*pi/nlon where sint = sin(theta(i)).
    !
    !     note:  for an irrotational vector field (v, w), subroutine igradgc
    !     computes a scalar field whose gradient is (v, w).  in ay case,
    !     subroutine igradgc "inverts" the gradient subroutine gradgc.
    !
    !     input parameters
    !
    !     nlat   the number of points in the gaussian colatitude grid on the
    !            full sphere. these lie in the interval (0, pi) and are computed
    !            in radians in theta(1) <...< theta(nlat) by subroutine compute_gaussian_latitudes_and_weights.
    !            if nlat is odd the equator will be included as the grid point
    !            theta((nlat + 1)/2).  if nlat is even the equator will be
    !            excluded as a grid point and will lie half way between
    !            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
    !            note: on the half sphere, the number of grid points in the
    !            colatitudinal direction is nlat/2 if nlat is even or
    !            (nlat + 1)/2 if nlat is odd.
    !
    !     nlon   the number of distinct londitude points.  nlon determines
    !            the grid increment in longitude as 2*pi/nlon. for example
    !            nlon = 72 for a five degree grid. nlon must be greater than
    !            3.  the efficiency of the computation is improved when nlon
    !            is a product of small prime numbers.
    !
    !
    !     isym   a parameter which determines whether the scalar field sf is
    !            computed on the full or half sphere as follows:
    !
    !      = 0
    !
    !            the symmetries/antsymmetries described in isym=1, 2 below
    !            do not exist in (v, w) about the equator.  in this case sf
    !            is neither symmetric nor antisymmetric about the equator.
    !            sf is computed on the entire sphere.  i.e., in the array
    !            sf(i, j) for i=1, ..., nlat and  j=1, ..., nlon
    !
    !      = 1
    !
    !            w is antisymmetric and v is symmetric about the equator.
    !            in this case sf is antisymmetyric about the equator and
    !            is computed for the northern hemisphere only.  i.e.,
    !            if nlat is odd sf is computed in the array sf(i, j) for
    !            i=1, ..., (nlat + 1)/2 and for j=1, ..., nlon.  if nlat is even
    !            sf is computed in the array sf(i, j) for i=1, ..., nlat/2
    !            and j=1, ..., nlon.
    !
    !      = 2
    !
    !            w is symmetric and v is antisymmetric about the equator.
    !            in this case sf is symmetyric about the equator and
    !            is computed for the northern hemisphere only.  i.e.,
    !            if nlat is odd sf is computed in the array sf(i, j) for
    !            i=1, ..., (nlat + 1)/2 and for j=1, ..., nlon.  if nlat is even
    !            sf is computed in the array sf(i, j) for i=1, ..., nlat/2
    !            and j=1, ..., nlon.
    !
    !
    !     nt     nt is the number of scalar and vector fields.  some
    !            computational efficiency is obtained for multiple fields.
    !            the arrays br, bi, and sf can be three dimensional corresponding
    !            to an indexed multiple vector field (v, w).  in this case,
    !            multiple scalar synthesis will be performed to compute each
    !            scalar field.  the third index for br, bi, and sf is the synthesis
    !            index which assumes the values k = 1, ..., nt.  for a single
    !            synthesis set nt = 1.  the description of the remaining
    !            parameters is simplified by assuming that nt=1 or that br, bi,
    !            and sf are two dimensional arrays.
    !
    !     isf    the first dimension of the array sf as it appears in
    !            the program that calls igradgc. if isym = 0 then isf
    !            must be at least nlat.  if isym = 1 or 2 and nlat is
    !            even then isf must be at least nlat/2. if isym = 1 or 2
    !            and nlat is odd then isf must be at least (nlat + 1)/2.
    !
    !     jsf    the second dimension of the array sf as it appears in
    !            the program that calls igradgc. jsf must be at least nlon.
    !
    !     br, bi  two or three dimensional arrays (see input parameter nt)
    !            that contain vector spherical harmonic coefficients
    !            of the vector field (v, w) as computed by subroutine vhagc.
    !     ***    br, bi must be computed by vhagc prior to calling igradgc.
    !
    !     mdb    the first dimension of the arrays br and bi as it appears in
    !            the program that calls igradgc (and vhagc). mdb must be at
    !            least min(nlat, nlon/2) if nlon is even or at least
    !            min(nlat, (nlon + 1)/2) if nlon is odd.
    !
    !     ndb    the second dimension of the arrays br and bi as it appears in
    !            the program that calls igradgc (and vhagc). ndb must be at
    !            least nlat.
    !
    !
    !  wshsgc    an array which must be initialized by subroutine shsgci.
    !            once initialized,
    !            wshsgc can be used repeatedly by igradgc as long as nlon
    !            and nlat remain unchanged.  wshsgc must not be altered
    !            between calls of igradgc.
    !
    !
    !  lshsgc    the dimension of the array wshsgc as it appears in the
    !            program that calls igradgc. define
    !
    !               l1 = min(nlat, (nlon+2)/2) if nlon is even or
    !               l1 = min(nlat, (nlon + 1)/2) if nlon is odd
    !
    !            and
    !
    !               l2 = nlat/2        if nlat is even or
    !               l2 = (nlat + 1)/2    if nlat is odd.
    !
    !
    !            then lshsgc must be at least
    !
    !               nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15
    !
    !     output parameters
    !
    !
    !     sf    a two or three dimensional array (see input parameter nt) that
    !           contain a scalar field whose gradient is the irrotational
    !           component of the vector field (v, w).  the vector spherical
    !           harmonic coefficients br, bi were precomputed by subroutine
    !           vhagc.  sf(i, j) is given at the gaussian colatitude theta(i)
    !           and longitude lambda(j) = (j-1)*2*pi/nlon.  the index ranges
    !           are defined at input parameter isym.
    !
    !
    !  ierror   = 0  no errors
    !           = 1  error in the specification of nlat
    !           = 2  error in the specification of nlon
    !           = 3  error in the specification of isym
    !           = 4  error in the specification of nt
    !           = 5  error in the specification of isf
    !           = 6  error in the specification of jsf
    !           = 7  error in the specification of mdb
    !           = 8  error in the specification of ndb
    !           = 9  error in the specification of lshsgc
    !
    subroutine igradgc(nlat, nlon, isym, nt, sf, isf, jsf, br, bi, mdb, ndb, &
        wshsgc, ierror)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip), intent(in)  :: isym
        integer(ip), intent(in)  :: nt
        real(wp),    intent(out) :: sf(isf, jsf, nt)
        integer(ip), intent(in)  :: isf
        integer(ip), intent(in)  :: jsf
        real(wp),    intent(in)  :: br(mdb, ndb, nt)
        real(wp),    intent(in)  :: bi(mdb, ndb, nt)
        integer(ip), intent(in)  :: mdb
        integer(ip), intent(in)  :: ndb
        real(wp),    intent(in)  :: wshsgc(:)
        integer(ip), intent(out) :: ierror

        ! Local variables
        integer(ip) :: imid, n1, n2, mmax
        integer(ip) :: required_wavetable_size

        ! Check calling arguments
        ierror = 1
        if (nlat < 3) return
        ierror = 2
        if (nlon < 4) return
        ierror = 3
        if (isym < 0 .or. isym > 2) return
        ierror = 4
        if (nt < 0) return
        ierror = 5
        imid = (nlat + 1)/2
        if ((isym == 0 .and. isf<nlat) .or. &
            (isym /= 0 .and. isf<imid)) return
        ierror = 6
        if (jsf < nlon) return
        ierror = 7
        mmax = min(nlat, (nlon+2)/2)
        if (mdb < min(nlat, (nlon + 1)/2)) return
        ierror = 8
        if (ndb < nlat) return
        ierror = 9
        !
        !     verify saved workspace length
        !
        n2 = (nlat+mod(nlat, 2))/2
        n1 = min((nlon+2)/2, nlat)
        required_wavetable_size = nlat*(2*n2+3*n1-2)+3*n1*(1-n1)/2+nlon+15
        if (size(wshsgc) < required_wavetable_size) return
        ierror = 0

        call invert_gradient_lower_utility_routine(nlat, nlon, isym, nt, sf, &
            br, bi, wshsgc, shsgc, ierror)

    end subroutine igradgc

end submodule invert_gradient_gaussian_grid


PROGRAM test_ave_value
!
!  Purpose:
!    To test function ave_value by calling it with a user-defined
!    function my_func.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    11/24/06    S. J. Chapman        Original code
!
IMPLICIT NONE

! Data dictionary: declare function types
REAL :: ave_value              ! Average value of function
REAL, EXTERNAL :: my_function  ! Function to evaluate

! Data dictionary: declare local variable types & definitions
REAL :: ave                    ! Average of my_function

! Call function with func=my_function.
ave = ave_value ( my_function, 0., 1., 101 )
WRITE (*,1000) 'my_function', ave
1000 FORMAT (1X,'The average value of ',A,' between 0. and 1. is ', &
             F16.6,'.')

END PROGRAM test_ave_value

REAL FUNCTION my_function( x )
IMPLICIT NONE
REAL, INTENT(IN) :: x
my_function = 3. * x
END FUNCTION my_function


** Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
** See https://llvm.org/LICENSE.txt for license information.
** SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

*   Intrinsics and generics: MAX and MIN - (no constant folding).

	implicit double precision (d)
	common rslts
	parameter(n = 26)
	integer rslts(n), expect(n)

	data i2, i5, in5 / 2, 5, -5 /
	data x2, x5, x15, xn5 / 2.0, 5.0, 1.5, -5.0 /
	data d2, d5, d15, dn5 / 2.0, 5.0, 1.5, -5.0 /

c --- tests 1 - 6: INTEGER MAX and MIN operations with 2 arguments:

	rslts(1) = max(i2, i5) + max(-1, in5)
	rslts(2) = max0(i5 + i2, 6) - min0(0, i5 * i2)
	rslts(3) = min(i2, -i5) * min(-i5, 0)
	rslts(4) = min(max(3, i2), i5 + i5)
c       use rslts(5) to count number of calls of function if:
	rslts(5) = 0
	rslts(min(i5+1, '7fffffff'x)) = max0(if(3), if(4))

c --- tests 7 - 12: REAL and DOUBLE PRECISION MAX and MIN:

	rslts(7) = ifix(max(x5, x2)) + ifix(amax1(-1.0, xn5))
	rslts(8) = amax1(x2, x15+1.0) + min(x15, -xn5)
	rslts(9) = amin1(0.0, xn5) * min(x2-x5, 2.35)

	rslts(10) = idint(min(d2, d5)) + idint(dmin1(dn5, -1.0d0))
	rslts(11) = dmin1(d15, d2+1.0) - max(-d15, dn5)
	rslts(12) = dmax1(1.5d0, d2-1) * max(dn5*(-d2), 0.0d0)

c --- tests 13 - 16: MAX and MIN operations which convert types:

	rslts(13) = ifix(amax0(i5, i2))
	rslts(14) = max1(2.5, x2) * 2.01
	rslts(15) = ifix(amin0(i5, i2))
	rslts(16) = 2.01 * min1(xn5/(-2.0), -xn5)

c --- tests 17 - 26: MAX and MIN operations with 3 or more arguments:

	rslts(17) = max(5, i2, -i2)
	rslts(18) = amax1(x2, 1+x5, 2.3, x5-x2)
	rslts(19) = max(d2, -d2, 2.5d0) * 2
	rslts(20) = amax0(3, 2, 1, i2)
	rslts(21) = max1(x2, x2, -5.0)

	rslts(22) = min0(-i2, i2, 5)
	rslts(23) = i2 * min(-xn5, 2.6, -xn5)
	rslts(24) = dmin1(5.0d0, 0.0d0, -d2)
	rslts(25) = if2(amin0(1, 2, -i2, -i5, -100))
	rslts(26) = min1(x2, -x2, -2.5) * 2

c --- check results:

	call check(rslts, expect, n)

c         --- tests 1 - 6:
	data expect / 4, 7, 25, 3, 2, -3,
c         --- tests 7 - 12:
     +                4, 4, 15, -3, 3, 15,
c         --- tests 13 - 16:
     +                5, 4, 2, 4,
c         --- tests 17 - 26:
     +                5, 6, 5, 3, 2, -2, 5, -2, 101, -4 /
	end

	integer function if(i)
	common rslts
	integer rslts(26)
	if = - i
	rslts(5) = rslts(5) + 1
	end

	integer function if2(x)
	if2 = ((-x) + 1.01)
	return
	end