      DOUBLE PRECISION FUNCTION BESFJ0(X)
C     BESSEL FUNCTION J0(X)
C
      DOUBLE PRECISION X
      DOUBLE PRECISION SRNAME
      DOUBLE PRECISION A, B, C, CX, G, SX, T2, T, TBPI, XBIG, XVSMAL, Y
      DOUBLE PRECISION DCOS, DSIN, DSQRT
C     ..
      DATA SRNAME /8H BESFJ0 /
      DATA XBIG,XVSMAL,TBPI/3.4D+15,3.2D-9,6.36619772367581343D-1/
C
      T = DABS(X)
C     ERROR 1 TEST
      IF (T.GT.XBIG) GO TO 60
C     X RANGE TEST
      IF (T.GT.8.0D0) GO TO 40
C     SMALL X
C      TEST FOR VERY SMALL X
      IF (T.GT.XVSMAL) GO TO 20
      BESFJ0 = 1.0D0
      GO TO 80
   20 T = 3.125D-2*T*T - 1.0D0
      T2 = 2.0D0*T
C
C
      A= +4.125321000000D-14
      B=T2*A -1.943834690000D-12
      C=T2*B-A +7.848696314000D-11
      A=T2*C-B  -2.679253530560D-9
      B=T2*A-C  +7.608163592419D-8
      C=T2*B-A  -1.761946907762D-6
      A=T2*C-B  +3.246032882101D-5
      B=T2*A-C  -4.606261662063D-4
      C=T2*B-A  +4.819180069468D-3
      A=T2*C-B  -3.489376941141D-2
      B=T2*A-C  +1.580671023321D-1
      C=T2*B-A  -3.700949938726D-1
      A=T2*C-B  +2.651786132033D-1
      B=T2*A-C  -8.723442352852D-3
      Y=T*B-A  +1.577279714749D-1
C
      BESFJ0 = Y
      GO TO 80
C
C     LARGE X
   40 G = T - 0.5D0/TBPI
      Y = DSQRT(TBPI/T)
      CX = DCOS(G)*Y
      SX = -DSIN(G)*Y*8.0D0/T
      T = 128.0D0/(T*T) - 1.0D0
C
C
      Y=  +9.99457276D-1+T*(  -5.36366929D-4+T*(  +6.13732440D-6+
     AT*(  -2.06823782D-7+T*(  +1.30451717D-8))))
C
      G=  -1.55551139D-2+T*(  +6.83314931D-5+T*(  -1.47708215D-6+
     AT*(  +7.10458046D-8+T*(  -5.81753275D-9+T*( +6.75219505D-10)))))
C
C
      BESFJ0 = Y*CX + G*SX
      GO TO 80
C
   60 WRITE(6,61) SRNAME
   61 FORMAT(1X,//,'ERROR IN ',A8)
      BESFJ0 = DSQRT(TBPI/T)
C
   80 RETURN
      END
      DOUBLE PRECISION FUNCTION BESFJ1(X)
C     BESSEL FUNCTION J1(X)
C
      DOUBLE PRECISION X
      DOUBLE PRECISION SRNAME
      DOUBLE PRECISION A, B, C, CX, G, SX, T2, T, TBPI, XBIG, XVSMAL, Y
      DOUBLE PRECISION DCOS, DSIN, DSQRT
      DATA SRNAME /8H BESFJ1 /
      DATA XVSMAL,XBIG,TBPI/3.2D-9,3.4D+15,6.36619772367581343D-1/
C
      T = DABS(X)
C     ERROR 1 TEST
      IF (T.GT.XBIG) GO TO 60
C     X RANGE TEST
      IF (T.GT.8.0D0) GO TO 40
C     SMALL X
      Y = 4.0D0
C      TEST FOR VERY SMALL X
      IF (T.LE.XVSMAL) GO TO 20
      T = 3.125D-2*T*T - 1.0D0
      T2 = 2.0D0*T
C
      A= -5.777404200000D-13
      B=T2*A +2.528123664000D-11
      C=T2*B-A -9.424212981600D-10
      A=T2*C-B  +2.949707007278D-8
      B=T2*A-C  -7.617587805400D-7
      C=T2*B-A  +1.588701923993D-5
      A=T2*C-B  -2.604443893486D-4
      B=T2*A-C  +3.240270182684D-3
      C=T2*B-A  -2.917552480615D-2
      A=T2*C-B  +1.777091172397D-1
      B=T2*A-C  -6.614439341345D-1
      C=T2*B-A  +1.287994098858D+0
      A=T2*C-B  -1.191801160541D+0
      Y=T*A-C  +6.483587706053D-1
C
C
   20 BESFJ1 = Y*X*0.125D0
      GO TO 80
C
C     LARGE X
   40 G = T - 1.5D0/TBPI
      Y = DSIGN(DSQRT(TBPI/T),X)
      CX = DCOS(G)*Y
      SX = -DSIN(G)*Y*8.0D0/T
      T = 128.0D0/(T*T) - 1.0D0
C
C
      Y=  +1.00090703D+0+T*(  +8.98804504D-4+T*(  -7.95959347D-6+
     AT*(  +2.47105358D-7+T*(  -1.49751260D-8))))
C
C
C
      G=  +4.67768740D-2+T*(  -9.62145905D-5+T*(  +1.82113970D-6+
     AT*(  -8.29018528D-8+T*(  +6.58335466D-9+T*( -7.49818190D-10)))))
C
C
      BESFJ1 = Y*CX + G*SX
      GO TO 80
C     ERROR 1 EXIT
   60 WRITE(6,61) SRNAME
   61 FORMAT(1X,//,'ERROR IN ',A8)
      BESFJ1 = DSQRT(TBPI/T)
C
   80 RETURN
      END
      COMPLEX*16 FUNCTION BESHS0(X, IFAIL)
C     COMPLEX*16 BESHS0
C-----------------------------------------------------------------------
C     BESSEL FUNCTION HS0(X)
C
C                           COMPUTED USING CHEBYSHEV REPRESENTATION
C
C-----------------------------------------------------------------------
C
      DOUBLE PRECISION X
      INTEGER IFAIL
      DOUBLE PRECISION SRNAME
      DOUBLE PRECISION A, B, C, CX, G, SX, T2, T, TBPI, XBIG, XVSMAL, Y
      DOUBLE PRECISION DCOS, DSIN, DSQRT, P, Q, Z
      DATA SRNAME /8H BESHS0 /
      DATA XBIG,XVSMAL,TBPI/3.4D+15,3.2D-9,6.36619772367581343D-1/
C
      T = DABS(X)
C     ERROR 1 TEST
      IF (T.GT.XBIG) GO TO 60
      IFAIL = 0
C     X RANGE TEST
      IF (T.GT.8.0D0) GO TO 40
C     SMALL X
C      TEST FOR VERY SMALL X
      IF (T.GT.XVSMAL) GO TO 20
      BESFJ0 = 1.0D0
      GO TO 80
   20 T = 3.125D-2*T*T - 1.0D0
      T2 = 2.0D0*T
C
C
      A= +4.125321000000D-14
      B=T2*A -1.943834690000D-12
      C=T2*B-A +7.848696314000D-11
      A=T2*C-B  -2.679253530560D-9
      B=T2*A-C  +7.608163592419D-8
      C=T2*B-A  -1.761946907762D-6
      A=T2*C-B  +3.246032882101D-5
      B=T2*A-C  -4.606261662063D-4
      C=T2*B-A  +4.819180069468D-3
      A=T2*C-B  -3.489376941141D-2
      B=T2*A-C  +1.580671023321D-1
      C=T2*B-A  -3.700949938726D-1
      A=T2*C-B  +2.651786132033D-1
      B=T2*A-C  -8.723442352852D-3
      Y=T*B-A  +1.577279714749D-1
C
      BESHS0 = DCMPLX(Y,0.0D0)
      GO TO 80
C
C     LARGE X
   40 G = T - 0.5D0/TBPI
      Y = DSQRT(TBPI/T)
      CX = DCOS(G)*Y
      SX = DSIN(G)*Y
      Z = 128.0D0/(T*T) - 1.0D0
C
C
      P=  +9.99457276D-1+Z*(  -5.36366929D-4+Z*(  +6.13732440D-6+
     AZ*(  -2.06823782D-7+Z*(  +1.30451717D-8))))
C
C
      Q=  -1.55551139D-2+Z*(  +6.83314931D-5+Z*(  -1.47708215D-6+
     AZ*(  +7.10458046D-8+Z*(  -5.81753275D-9+Z*( +6.75219505D-10)))))
C
      Q = Q*8.0D0/T
C
      BESHS0 = DCMPLX(P,Q)*DCMPLX(CX,SX)
      GO TO 80
C
C     ERROR 1 EXIT
   60 WRITE(6,61) SRNAME
   61 FORMAT(1X,//,'ERROR IN ',A8)
      BESHS0 = DCMPLX(TBPI/T,0.0D0)
C
   80 RETURN
      END


program plot_potential
use precisions, only : dp
use delta_shell, only : nn_model
use exp_data, only : nn_experiment
use optimization, only : setup_optimization, covariance_matrix
use chi_square, only : total_chi_square
use read_write, only : plot_potential_components
implicit none
type(nn_model) :: model
real(dp), allocatable, dimension(:) :: parameters
logical, allocatable, dimension(:) :: mask
type(nn_experiment), allocatable, dimension(:) :: database
logical :: save_results
character(len=1024) :: output_file
integer :: n_points
real(dp) :: chi2
real(dp), allocatable, dimension(:, :) :: alpha, covariance
real(dp), allocatable, dimension(:) :: beta
real(dp), parameter :: r_min = 0.0_dp, r_max = 2.0_dp, r_step = 0.0078125_dp

call setup_optimization(model, parameters, mask, database, save_results, output_file)
call total_chi_square(database, parameters, mask, model, n_points, chi2, alpha, beta)
covariance = covariance_matrix(alpha, mask)
call plot_potential_components(model, parameters, covariance, r_min, r_max, r_step, output_file)

end program plot_potential


        SUBROUTINE R4FFT(C,ID1,ID2,N1,N2,N3,N4,W1,W2,W3,W4,ISIG,IORD,
     &                   IWORK,IERR)
C======================================================================*
C R4FFT -- 4 Dimensional Real Fast Fourier Transformation
C
C PURPOSE:
C       THIS ROUTINE PERFORMS A 4-DIMENSIONAL REAL FOURIER TRANSFORM
C       OF ORDER N1*N2*N3*N4
C
C USAGE:
C       THE USER IS EXPECTED TO PROVIDE THE DATA IN A 4-DIMENSIONAL
C       REAL ARRAY C, DIMENSIONED IN THE CALLING PROGRAM AS
C
C          REAL C(ID1,ID2,N3,N4)
C
C       THE RESULTS ARE RETURNED IN THE SAME STORAGE SPACE AS A
C       COMPLEX ARRAY CCOM
C
C         COMPLEX CCOM(ID1/2,ID2,N3,N4)
C
C       ID1 MUST BE AN EVEN INTEGER EQUAL TO N1+2; FOR OPTIMAL PERFORMANCE,
C       ID1/2  AND ID2 SHOULD BE ODD, AND ID2 SHOULD BE EQUAL TO N2 OR
C       N2+1, DEPENDING IF N2 IS ODD OR EVEN.
C
C       THE ROUTINE IS INTENDED FOR REPEATED USAGE, THUS
C       SEPARATE SET-UP AND OPERATING CALLS ARE AVAILABLE: THE USER SHOULD
C       ALLWAYS PERFORM A SET-UP CALL ( ISIG=0 ) PASSING THE
C       CORRECT VALUES OF THE ARGUMENTS, BEFORE PERFORMING THE
C       ACTUAL TRANSFORM ( ISIG= +1 OR -1 ); THE USER CAN CHOOSE
C       WHETHER TO OBTAIN THE RESULT OF A DIRECT TRANSFORM IN
C       NATURAL ORDER (ISIG=-1,IORD=1) OR IN "BIT-REVERSED" ORDER
C       (ISIG=-1,IORD=0); THIS CHOICE SAVES SOME COMPUTER TIME
C       IN CASES DISCUSSED IN THE LONG WRITE-UP. ANALOGOUSLY, THE
C       INVERSE TRANSFORM ACCEPTS INPUT IN NATURAL ORDER (ISIG=1,
C       IORD=1) OR IN "BIT-REVERSED" ORDER ( ISIG=1,IORD=-1).
C       THIS OPTION DOES NOT APPLY TO THE FIRST DIMENSION, THAT
C       IS REORDERED IN ANY CASE.
C
C ARGUMENTS:
C       C:
C          DECLARED REAL C(ID1,ID2,N3,N4) IN THE CALLING PROGRAM
C          INPUT: ARRAY TO BE TRANSFORMED;
C          OUTPUT: TRANSFORMED ARRAY IF ISIG.NE.0; UNCHANGED IF ISIG.EQ.0
C       ID1:
C          INTEGER;
C          INPUT: FIRST DIMENSION OF C, AS DECLARED IN THE CALLING PROGRAM
C       ID2:
C          INTEGER;
C          INPUT: SECOND DIMENSION OF C,AS DECLARED IN THE CALLING PROGRAM
C       N1:
C          INTEGER;
C          INPUT: ORDER OF THE TRANSFORM ALONG THE FIRST DIMENSION;
C                 N1.EQ.ID1-2 ;N1 MUST BE A PRODUCT OF POWERS OF 2,3,5
C               AND MUST BE EVEN;
C       N2:
C          INTEGER;
C          INPUT: ORDER OF THE TRANSFORM ALONG THE SECOND DIMENSION; N2.LE.
C                 N2 MUST BE A PRODUCT OF POWERS OF 2,3,5;
C       N3:
C          INTEGER;
C          INPUT: THIRD DIMENSION OF C, AS DECLARED IN THE CALLING PROGRAM,
C                 AND ORDER OF THE TRANSFORM ALONG THE THIRD DIMENSION
C                 N3 MUST BE A PRODUCT OF POWERS OF 2,3,5;
C       N4:
C         INTEGER;
C         INPUT: ORDER OF THE TRANSFORM ALONG THE FOURTH DIMENSION
C                 N1 MUST BE A PRODUCT OF POWERS OF 2,3,5;
C       W1,W2,W3,W4:
C         THEY MUST BE DECLARED IN THE CALLING PROGRAM AS
C         INTEGER W1(6*N1+14),W2(4*N2+14),W3(4*N3+14),W4(4*N4+14)
C         IF ANY OF THE N'S ARE EQUAL, THE CORRESPONDING W'S
C         DON'T NEED TO BE DISTINCT.
C         INPUT: IF ISIG.NE.0, THE W'S MUST CONTAIN THE TABLES PREPARED
C                BY A PREVIOUS CALL WITH THE SAME ARGUMENTS BUT ISIG.EQ.0.
C         OUTPUT: IF ISIG.EQ.0, THE W ARE FILLED WITH THE TABLES REQUIRED
C                 FOR THE TRANSFORM. IF ISIG.NE.0, UNCHANGED.
C       IORD:
C         INTEGER;
C         INPUT: IF IORD.EQ.0, NO REORDERING IS PERFORMED AFTER A DIRECT
C                TRANSFORM, SO THAT THE RESULTS ARE LEFT IN "BIT REVERSED"
C                ORDER; AND NO PERMUTATION IS PERFORMED BEFORE THE INVERSE
C                TRANSFORM, SO THAT THE INPUT MATRIX IS REQUIRED TO BE
C                ALREADY IN"BIT-REVERSED" ORDER; IF IORD.NE.0, OUTPUT OF
C                DIRECT TRANSFORM AND INPUT TO INVERSE TRANSFORM ARE IN
C                NATURAL ORDER; THE ABOVE OPTION APPLIES ONLY TO THE SECOND
C                THIRD AND FOURTH DIMENSION, SINCE THE FIRST ONE IS REORDER
C              IN ANY CASE
C       ISIG:
C         INTEGER;
C         INPUT: IF ISIG.LT.0  , DIRECT TRANSFORM ( C(J)EXP(-2*PI*I*J*K/N))
C                IF ISIG.GT.0  , INVERSE TRANSFORM ( C(J)EXP(2*PI*I*J*K/N))
C                IF ISIG.EQ.0  , SETUP RUN ( FILLING OF THE W'S )
C       IWORK:
C         INTEGER ARRAY, OF SIZE MAX(N1,N2,N3,N4)
C         WORK AREA;
C       IERR:
C         INTEGER:
C         OUTPUT: ERROR CODE:
C                 0 :NO ERRORS;
C                 1 :ID1.LT.N1 OR ID2.LT.N2;
C                 2 :ONE OF THE N'S CONTAINS A FACTOR DIFFERENT FROM 2,3,5
C                 3 :IN A CALL WITH ISIG.NE.0, SOME OF THE W'S CONTAINED
C                      ILLEGAL VALUES
C                 4 :N1 IS ODD
C
C For further documentation see A. Nobile and V. Roberto,
C "MFFT: A Package for Two and Three Dimensional Vectorized
C Discrete Fourier Transforms", Computer Physics Communications vol. 42,
C pp 233-247 (1986), and "Efficient Implementation of Multidimensional
C Fast Fourier Transformation on a Cray X-MP", Computer Physics
C Communications, vol. 40, pp 189-201 (1986).
C======================================================================*
        COMPLEX C(0:*)
        INTEGER W1(-14:*),W2(-14:*),W3(-14:*),W4(-14:*)
        INTEGER IWORK(*)
        INTEGER IDERR,FACERR,TBERR
        PARAMETER(IDERR=1,FACERR=2,TBERR=3,ODDERR=4)

C BEGIN:

        IF(ID1.NE.N1+2.OR.ID2.LT.N2)THEN
                IERR=IDERR
                RETURN
        ENDIF
        N12=N1/2
        IF(2*N12.NE.N1)THEN
                IERR=ODDERR
                RETURN
        ENDIF

        IERR=0
        IF(ISIG.EQ.0)THEN

                CALL MFFTRP(N1,W1(4*N1))
                CALL MFFTP(N12,W1,0,IERR)
                IF(IERR.NE.0)RETURN
                IF(N2.EQ.N12)THEN
                        CALL MFFTZ0(W1,1,4*N12+14,W2,1)
                ELSE
                        CALL MFFTP(N2,W2,0,IERR)
                        IF(IERR.NE.0)RETURN
                ENDIF
                IF(N3.EQ.N12)THEN
                        CALL MFFTZ0(W1,1,4*N12+14,W3,1)
                ELSE IF(N3.EQ.N2)THEN
                        CALL MFFTZ0(W2,1,4*N2+14,W3,1)
                ELSE
                        CALL MFFTP(N3,W3,0,IERR)
                        IF(IERR.NE.0)RETURN
                ENDIF
                IF(N4.EQ.N12)THEN
                        CALL MFFTZ0(W1,1,4*N12+14,W4,1)
                ELSE IF(N4.EQ.N2)THEN
                        CALL MFFTZ0(W2,1,4*N2+14,W4,1)
                ELSE IF (N4.EQ.N3)THEN
                        CALL MFFTZ0(W3,1,4*N3+14,W4,1)
                ELSE
                        CALL MFFTP(N4,W4,0,IERR)
                        IF(IERR.NE.0)RETURN
                ENDIF
                RETURN

        ELSE  IF(ISIG.GT.0)THEN

                IF(IORD.NE.0)THEN
                        CALL MFFTOM(C,ID1/2,1,ID1/2*ID2,N2,N12+1,N3*N4,
     &                              W2(3*N2) ,IWORK)
                        CALL MFFTOM(C,ID1/2*ID2,ID1/2*ID2*N3,1,N3,N4,
     &                              ID1/2*N2,W3(3*N3),IWORK)
                        CALL MFFTOV(C,ID1/2*ID2*N3,1,N4,ID1/2*ID2*N3,
     &                              W4(3*N4),IWORK)
                ENDIF

                IF(IERR.NE.0)RETURN
                CALL MFFTIM(C,ID1/2,1,ID1/2*ID2,N2,N12+1,N3*N4,W2,IERR)
                IF(IERR.NE.0)RETURN
                CALL MFFTIM(C,ID1/2*ID2,ID1/2*ID2*N3,1,N3,N4,ID1/2*N2,W3
     &                      ,IERR)
                IF(IERR.NE.0)RETURN
                CALL MFFTIV(C,ID1/2*ID2*N3,1,N4,ID1/2*ID2*N3,W4,IERR)

                CALL MFFTRI(C,1,ID1/2,N12,ID2*N3*N4,W1(4*N1))
                CALL MFFTOV(C,1,ID1/2,N12,ID2*N3*N4,W1(3*N12),IWORK)
                CALL MFFTIV(C,1,ID1/2,N12,ID2*N3*N4,W1,IERR)
        ELSE

                CALL MFFTDV(C,1,ID1/2,N12,ID2*N3*N4,W1,IERR)
                CALL MFFTOV(C,1,ID1/2,N12,ID2*N3*N4,W1(2*N12),IWORK)
                CALL MFFTRD(C,1,ID1/2,N12,ID2*N3*N4,W1(4*N1))

                IF(IERR.NE.0)RETURN
                CALL MFFTDM(C,ID1/2,1,ID1/2*ID2,N2,N12+1,N3*N4,W2,IERR)
                IF(IERR.NE.0)RETURN
                CALL MFFTDM(C,ID1/2*ID2,ID1/2*ID2*N3,1,N3,N4,ID1/2*N2,W3
     &                      ,IERR)
                IF(IERR.NE.0)RETURN
                CALL MFFTDV(C,ID1/2*ID2*N3,1,N4,ID1/2*ID2*N3,W4,IERR)

                IF(IORD.NE.0)THEN
                        CALL MFFTOM(C,ID1/2,1,ID1/2*ID2,N2,N12+1,N3*N4,
     &                             W2(2*N2),IWORK)
                        CALL MFFTOM(C,ID1/2*ID2,ID1/2*ID2*N3,1,N3,N4,
     &                              ID1/2*N2,W3(2*N3),IWORK)
                        CALL MFFTOV(C,ID1/2*ID2*N3,1,N4,ID1/2*ID2*N3,
     &                              W4(2*N4),IWORK)
                ENDIF
        ENDIF
        END


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      SUBROUTINE EXDSCT (MXND, XN, YN, LNODES, ANGLE, N1, XNEW, YNEW)
C***********************************************************************

C  SUBROUTINE EXCORN = CALCULATES A POSITION AN AVERAGE LENGTH AWAY
C                      FROM A DISSECTION NODE

C***********************************************************************

      DIMENSION XN (MXND), YN (MXND), LNODES (7, MXND), ANGLE (MXND)

      N0 = LNODES (2, N1)
      N2 = LNODES (3, N1)

C      XNEW = XN (N0) + XN (N2) - XN (N1)
C      YNEW = YN (N0) + YN (N2) - YN (N1)

      PID2 = 0.5 * ATAN2(0.0, -1.0)

      ANG = ATAN2 (YN (N0) - YN (N1), XN (N0) - XN (N1)) -
     &   (ANGLE (N1) - PID2)
C     &   (2. * ANGLE(N1) / 3.)
      DIST1 = SQRT ((YN (N2) - YN (N1)) **2 +  (XN (N2) - XN (N1)) **2)
      DIST2 = SQRT ((YN (N0) - YN (N1)) **2 +  (XN (N0) - XN (N1)) **2)
      DIST = (DIST1 + DIST2) * .5
      XNEW = DIST * COS (ANG) + XN (N1)
      YNEW = DIST * SIN (ANG) + YN (N1)

      RETURN

      END


C-----THIS IS A TEST OF MODULE PPROJ
      INCLUDE 'VICMAIN_FOR'
	SUBROUTINE MAIN44
C-----THIS ROUTINE WILL SET UP A DATA BUFFER FOR INPUT TO PPROJ.
C-----PPROJ WILL THEN CONVERT (L,S) TO (LAT,LON) OR INVERSE.
	IMPLICIT REAL (A-Z)
        CHARACTER*132 PBUF
	INTEGER ILAT,IND
	REAL MAP(40)
CCCC      REAL*8 OM(3,3),RS(3)                    FYI, BUT NOT REFERENCED.
CCCC      EQUIVALENCE (MAP,OM),(MAP(19),RS)
C
	CALL ZIA(MAP,40)
	MAP(25) = 1000.             ! POLAR RADIUS       KM
	MAP(26) = 1500.             ! EQUATORIAL RADIUS  KM
	MAP(27) = 1500.             ! FOCAL LENGTH IN MM
	MAP(28) = 500.              ! OPTICAL AXIS LINE NUMBER
	MAP(29) = 500.              ! OPTICAL AXIS SAMP NUMBER
	MAP(30) = 100.              ! SCALE   PX/MM
	MAP(31) = 10.               ! SUB SPCRFT POINT  LAT
	MAP(32) = 10.               ! SUB SPCRFT POINT  LON
	MAP(33) = 300.              ! SUB SPCRFT POINT  LINE
	MAP(34) = 400.              ! SUB SPCRFT POINT  SAMP
	MAP(35) = 20.               ! NORTH ANGLE
	MAP(38) = 100000.           ! RANGE TO CENTER OF PLANET  KM
	CALL FORMOM(MAP)            ! CREATE OM AND RS
C
C-----ALL SET TO TRY PPROJ
	LINE = 400.
	SAMP = 500.
10	ILAT = 1	! GEODETIC LAT
	CALL XVMESSAGE('DERIVE (LT,LN) FROM (L,S)',' ')
	CALL PPROJ(MAP,LINE,SAMP,LAT,LON,2,ILAT,RTANG,SLANT,IND)
	IF (IND.EQ.0) THEN
	  CALL XVMESSAGE('POINT IS OFF PLANET',' ')
	  CALL PRNT(7,1,RTANG,'TANGENT RADIUS =.')
	ELSE
          WRITE (PBUF,9000) LINE,SAMP,LAT,LON
9000      FORMAT ('L,S,LT,LN', 1PE10.3,1PE10.3,1PE10.3,1PE10.3)
          CALL XVMESSAGE(PBUF, ' ')
	  CALL PRNT(7,1,RTANG,'RADIUS =.')
	  CALL PRNT(7,1,SLANT,'SLANT DISTANCE =.')
	ENDIF
C  PUT IN A TEST FOR RTANG OPTION:
        IF (LINE.GT.400.) GO TO 15
	LINE = 1500.
	SAMP = 5000.
	GO TO 10
15	LAT = 30.
	LON = 5.
	CALL XVMESSAGE('DERIVE (L,S) FROM (LT,LN)',' ')
	CALL PPROJ(MAP,LINE,SAMP,LAT,LON,1,ILAT,RTANG,SLANT,IND)
	IF (IND.ne.0) then
          WRITE (PBUF,9000) LINE,SAMP,LAT,LON
          CALL XVMESSAGE(PBUF, ' ')
	else
20	CALL XVMESSAGE('POINT IS ON BACKSIDE OF PLANET',' ')
        end if
        CALL XVMESSAGE(
     . 'Repeat test case in C to test C interface: zpproj', ' ')

        call tzpproj(MAP)

	RETURN
	END

C     THIS IS IBM SUBROUTINE FARENC   -----NAME CHANGE-----
C/*   2 FEB 83   ...CCA...     INITIAL RELEASE
      SUBROUTINE FORMOM(DATA)
C ROUTINE TO SET UP CAMERA POINTING GEOMETRY INFO FOR CALCULATION OF
C THE PLANET-TO-CAMERA ROTATION MATRIX (OM).
      IMPLICIT DOUBLE PRECISION (A-Z)
      REAL DATA(*)
C
      PI = 3.141592653589793D0
      RADDEG = 180.D0 / PI
      DEGRAD = PI / 180.D0
      FL = DATA(27)
      OAL = DATA(28)
      OAS = DATA(29)
      SCALE = DATA(30)
      LAT = DATA(31)
      LON = DATA(32)
      LSS = DATA(33)
      SSS = DATA(34)
      NA = DATA(35)
      D = DATA(38)
C          CONVERT FROM GEODETIC TO GEOCENTRIC LATITUDE
      IF(DABS(LAT).EQ.90.D0) GOTO 10
      RP = DATA(25)
      RE = DATA(26)
      E = RE/RP
      LAT = DATAN(DTAN(LAT*DEGRAD)/E**2)*RADDEG
   10 CALL MOMATI(OAL,OAS,LSS,SSS,SCALE,FL,LON,LAT,NA,D,DATA,DATA(19))
      RETURN
C
      END


C * * * * * * * * * * * * * * * * * * * * * * * * *
C --- DRIVER FOR DOPRI5 ON N-body problem
C * * * * * * * * * * * * * * * * * * * * * * * * *
cfeh dr_dop853 dop853
        include 'dop853.f'
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        PARAMETER (NDGL=2400,NRD=0)
        PARAMETER (LWORK=11*NDGL+8*NRD+21,LIWORK=NRD+21)
        DIMENSION Y(NDGL),WORK(LWORK),IWORK(LIWORK)
        EXTERNAL FNBOD,SOLOUT
C --- DIMENSION OF THE SYSTEM
        N=2400
        RPAR=1.0D-3
C --- OUTPUT ROUTINE (AND DENSE OUTPUT) IS USED DURING INTEGRATION
        IOUT=0
C --- INITIAL VALUES
        X=0.0D0
        pi=3.141592653589d0
        mbdy = 400
        rf1 = 4*pi/8
        rf2 = 2*pi/mbdy
        do i=1,mbdy
C          mass(i) = (0.3D0 +0.1D0*(cos(i*rf1)+1D0))/mbdy
          rad = 1.7D0+dcos(i*0.75D0)
          v = 0.22d0*dsqrt(rad)
          ci = dcos(i*rf2)
          si = dsin(i*rf2)
          ip = 6*(i-1)
          Y(ip+1) = rad*ci ! initial position
          Y(ip+2) = rad*si
          Y(ip+3) = 0.4D0*si
          Y(ip+4) = -v*si ! velocity is tangential
          Y(ip+5) = v*ci
          Y(ip+6) = 0.D0
        end do

C --- ENDPOINT OF INTEGRATION
        XEND=8.d-2
C --- REQUIRED (RELATIVE) TOLERANCE
        TOL=relative_tolerance
        ITOL=0
        RTOL=TOL
        ATOL=TOL
C --- DEFAULT VALUES FOR PARAMETERS
        DO 10 I=1,10
        IWORK(I)=0
  10    WORK(I)=0.D0
        IWORK(5)=0
        IWORK(4)=1000
C --- CALL OF THE SUBROUTINE DOPRI8
        CALL DOP853(N,FNBOD,X,Y,XEND,
     &                  RTOL,ATOL,ITOL,
     &                  SOLOUT,IOUT,
     &                  WORK,LWORK,IWORK,LIWORK,RPAR,IPAR,IDID)
C --- PRINT relative error
        OPEN(UNIT=12, FILE="reference.txt", ACTION="read")
        FERR = 0.d0
        do i=1,N
            READ(12,*) YREF
            FERR = FERR + ((Y(i)-YREF)/YREF)**2
        end do
        FERR = dsqrt(FERR/N)
        WRITE (6,97) FERR
 97     FORMAT(1X,'Error = ',E24.16)

C --- PRINT FINAL SOLUTION
        WRITE (6,99) X,Y(1),Y(2)
 99     FORMAT(1X,'X =',E24.16,'    Y =',2E24.16)
C --- PRINT STATISTICS
        WRITE (6,90) TOL
 90     FORMAT('       tol=',D8.2)
        WRITE (6,91) (IWORK(J),J=17,20)
 91     FORMAT(' fcn=',I5,' step=',I4,' accpt=',I4,' rejct=',I3)

C        OPEN(UNIT=12, FILE="solution.txt", ACTION="write",
C     &       STATUS="replace")
C        do i=1,N
C            WRITE (12,98) Y(i)
C        end do
C 98     FORMAT(1X,E24.16)

        STOP
        END
C
        SUBROUTINE SOLOUT (NR,XOLD,X,Y,N,CON,ICOMP,ND,
     &                                          RPAR,IPAR,IRTRN,XOUT)
C --- PRINTS SOLUTION AT EQUIDISTANT OUTPUT-POINTS
C --- BY USING "CONTD8", THE CONTINUOUS COLLOCATION SOLUTION
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION Y(N),CON(8*ND),ICOMP(ND)
        IF (NR.EQ.1) THEN
           WRITE (6,99) X,Y(1),Y(2),NR-1
           XOUT=0.1D0
        ELSE
 10        CONTINUE
           IF (X.GE.XOUT) THEN
              WRITE (6,99) XOUT,CONTD8(1,XOUT,CON,ICOMP,ND),
     &                     CONTD8(2,XOUT,CON,ICOMP,ND),NR-1
              XOUT=XOUT+0.1D0
              GOTO 10
           END IF
        END IF
 99     FORMAT(1X,'X =',F5.2,'    Y =',2E18.10,'    NSTEP =',I4)
        RETURN
        END
C
        SUBROUTINE FNBOD(N,X,Y,F,RPAR,IPAR)
C --- RIGHT-HAND SIDE OF N-body problem
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        DIMENSION Y(N),F(N)
        mbdy = 400
        eps  = 1.d-4
        dmass =  1.d0
        do i=1,mbdy
           ip = 6*(i-1)
           F(ip+1) = Y(ip+4)
           F(ip+2) = Y(ip+5)
           F(ip+3) = Y(ip+6)
           f1 = 0D0; f2 = 0D0; f3 = 0D0
          do j=1,mbdy ! compute gravity force body j <- i
            if (j.ne.i) then
              jp = 6*(j-1)
              dist=eps+(Y(ip+1)-Y(jp+1))**2+(Y(ip+2)-Y(jp+2))**2+
     &              (Y(ip+3)-Y(jp+3))**2
              dist = dmass/(dist*sqrt(dist))
              f1 = f1+(Y(jp+1)-Y(ip+1))*dist
              f2 = f2+(Y(jp+2)-Y(ip+2))*dist
              f3 = f3+(Y(jp+3)-Y(ip+3))*dist
            end if
          end do
          F(ip+4) = f1
          F(ip+5) = f2
          F(ip+6) = f3
        end do
        RETURN
        END


      subroutine perc(vv,k1)
c
c     + + + PURPOSE + + +
c     Returns percolation; ie, seepage (SEP) from the bottom of the
c     current soil layer (into the layer below) when field capacity
c     in the current layer is exceeded.  Correction is made for
c     saturation of the layer below.
c
c  Note:  There are inconsistencies in the array subscripts.
c         Some include IPLANE (OFE number) and J1 (soil layer).
c         Others just include a dimension for J1.  Computationally
c         it makes no difference, since an entire OFE is processed
c         before another is started.
c
c
c     Called from PURK
c     Author(s): Williams, Savabi, Meyer
c     Reference in User Guide:
c
c     Changes:
c           1) Common block UPDATE not used.  Dereferenced.
c           2) Global SAVE of all local variables deleted.
c           3) The function:
c                 funzz=.92283-.4936*zz+.048187*zz**2
c              was put in place to approximate the function:
c                 funzz=exp(-zz)
c              since it executes quicker.  Unfortunately, it is
c              is not a very good approximation over the desired
c              range (0 < zz <= 10).  Therefore, the original
c              equation was put back.  (See note below.)
c              *** THIS SLIGHTLY CHANGES THE OUTPUT. ***
c           4) The line:
c                 sup=sup-sep(iplane)
c              was removed with no difference in output.  (It was the
c              last statement executed before the RETURN, and SUP is
c              an unsaved local variable.
c           5) PERC was changed to receive the parameter VV in lieu of
c              getting SU from a common block.  This is to make the
c              code easier to follow, etc.  J1 was changed into para-
c              meter K1 for the same reason.  SU, J1, & J2 SHOULD BE
c              REMOVED FROM COMMON BLOCK 'WATER'.
c           6) The percent saturation of the current layer (STZ)
c              was being calculated with a water content (ST) which
c              included the water excess (VV).  The percent saturation
c              for the layer below (STU) was being calculated with a
c              water content that had VV subtracted.  This was changed
c              so that STU was calculated like STZ (with VV included)
c              (Conversation with Savabi 9/17/91.)
c           7) Variable CR moved out of computation of ZZ, and into
c              computation of SEP(IPLANE).  (Conversation with
c              Savabi 9/18/91.)
c
c   Note:  Two approximations to the equation: Y = exp(-X) were
c          derived, one second order and one third order.  The
c          second order is a pretty good match to the original
c          for values of X between 0 and 2.  Its values overshoot,
c          so by the time X reaches 10, its y-value is 200X too
c          large. The third order equation is a reasonable match
c          for values of X from 0 to 3.  It overshoots much less.
c          At X=10, it is (only) 100X too large.  Both approxi-
c          mations are measurably faster than their exponential
c          counterpart.  The equations are:
c           Y = 1/(x**2 + 0.8*x + 1.0) and
c           Y = 1/(0.12*x**3 + x**2 + 0.7*x + 1.0)
c                 CRM -- 8/27/91
c
c     Version: This module originally recoded from WEPP version 91.20.
c     Date recoded: 08/22/91 - 09/18/91.
c     Version: This module updated from WEPP release version 91.50.
c     Date updated: 12/03/91.
c     Recoded by: Charles R. Meyer.
c
c     Recoded by: Charles R. Meyer.
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
      include 'pmxnsl.inc'
      include 'pmxpln.inc'
      include 'pmxtls.inc'
      include 'pmxtil.inc'
      include 'pmxhil.inc'
c
c     + + + ARGUMENT DECLARATIONS + + +
      real vv
      integer k1
c
c     + + + ARGUMENT DEFINITIONS + + +
c     vv     - Water excess in the current layer.
c     k1     - Index of current soil layer.
c
c     + + + COMMON BLOCKS + + +
      include 'cstruc.inc'
c       read: iplane
c
      include 'cwater.inc'
c       read: st(mxnsl,mxplan),ul(mxnsl,mxplan),ssc(mxnsl,mxplan),hk(mxnsl)
c      write: sep(mxplan)
c
      include 'ctemp.inc'
c       read: slflag,rockn
c
      include  'cwint.inc'
c       read:  snodpt(iplane),tfrdp(mxplan),tthawd(mxplan),frdp(mxplan),
c              thdp(mxplan),densg(mxplan)
c
c     + + + LOCAL VARIABLES + + +
      real stz, fx, stu, cr, zz, funzz, sscz,vartm1,vartm2
c
c     + + + LOCAL DEFINITIONS + + +
c     stz    - percent saturation (expressed as a fraction)
c     fx     - correction factor for sat. hyd. cond. for unsat. soil
c              (equation 7.4.3)
c     stu    - percent saturation (fraction) of lower layer
c     cr     - correction factor for lower layer saturation
c              (equation 7.4.5)
c     zz     - travel time of water through the layer (days)
c              (a part of equation 7.4.19 -delta t/ti)
c     funzz  - a part of equation 7.4.1, 1-exp(-delta t/ti) but
c              linear form
c
c     + + + END SPECIFICATIONS + + +
c
c
c      Compute percent saturation (fraction) in the current layer.
c
cd    Modified by S. Dun, March 04, 2008 for forzen soil
cd          stz = st(k1,iplane) / ul(k1,iplane)
      stz = (st(k1,iplane) + frzw(k1,iplane)) / ul(k1,iplane)
      if (stz.lt.0.95) then
        fx = stz ** hk(k1)
        if (fx.lt.0.002) fx = 0.002
      else
        fx = 1.
      end if
c
c     Adjust the percolation rate for the saturation of the soil
c     layer below the current one.  (Chapter 7, equation 7.4.3)
c
c     Compute percent saturation (fraction) in the layer below.
      if (k1.lt.nsl(iplane)) then
cd          stu = st(k1+1,iplane) / ul(k1+1,iplane)
          stu = (st(k1+1,iplane) + frzw(k1+1,iplane)) / ul(k1+1,iplane)
          if (stu.ge.0.95) stu = 0.95
      else
        stu = 0.
      end if
c
cx    Added by Arthur. Incorperated by S. Dun Dec. 03, 2003
cx     Modificaitons are made to simulate the bottom rock layer.
cx     A specific K value is assigned to the bottom layer here.
cx     Arthur C.Xu Dec 12, 2000
cd    S. Dun changed K1 to K1+1
      if (k1.eq.nsl(iplane))then
        ssc(k1+1,iplane)= ssc(k1,iplane)
            if (slflag(iplane).eq.0)  ssc(k1+1,iplane)= ssc(k1,iplane)
            if (slflag(iplane).eq.1)  ssc(k1+1,iplane)= kslast(iplane)
      end if
cx     END OF ADDING
cx
c     *** L0 IF ***
      if (stu.lt.1.0) then
c       Correct for lower level saturation.  (Chapter 7, eq. 7.4.5)
                cr = sqrt(1.-stu)
c       Travel time of water (days) through the layer
cd    Modified by DSH 09/19/2002
        if(k1.eq.nsl(iplane)) then
           if(slflag(iplane).eq.0) ssc(k1+1,iplane)=ssc(k1,iplane)
            sscz = ssc(k1,iplane)*2/(ssc(k1,iplane)+ssc(k1+1,iplane))
     1                *ssc(k1+1,iplane)
        else
           sscz = ssc(k1,iplane)
cd         Added by S. Dun, Dec 01, 2007
c          for infiltration on frozen soil
           if ((frdp(iplane).gt.0.0).and.(sscv(k1,iplane).gt.0.0)) then
               sscz = sscv(k1,iplane)
           endif
cd         end adding
        endif
        zz = 86400. * fx * sscz / vv
cd        zz = 86400. * fx * ssc(k1,iplane) / vv
cd    End Modifying.
c
        if (zz.le.10.) then
c         Note: For positive values of ZZ, FUNZZ starts at 1.0, and
c         approaches a lower limit of zero at positive infinity.
c
c         (Chapter 7, equation 7.4.1)
          funzz = exp(-zz)
c         funzz = 1.0/(zz**2 + 0.8*zz + 1.0)
cC        funzz = 1.0/(0.12*zz**3 + zz**2 + 0.7*zz + 1.0)
c
          sep(iplane) = vv * (1.0-funzz) * cr
        else
c         If time > 10 days, FUNZZ approaches zero.
          sep(iplane) = vv * cr
        end if
c
c     If lower level is saturated, there is no seepage
c     from the current level....
c     *** L0 ELSE ***
      else
        sep(iplane) = 0.0
c
c     *** L0 ENDIF ***
      end if
c
      return
      end


module slope_module

  implicit none

contains

! :::
! ::: ------------------------------------------------------------------
! :::
      subroutine uslope(q,flatn,qd_l1,qd_h1,dq,qpd_l1,qpd_h1,ilo,ihi,nv)

!      use meth_params_module, only : QPRES
      use amrex_constants_module

      implicit none

      integer ilo, ihi, nv
      integer qd_l1,qd_h1,qpd_l1,qpd_h1
      double precision q(qd_l1:qd_h1, nv)
      double precision dq(qpd_l1:qpd_h1,nv)
      double precision flatn(qd_l1:qd_h1)

!     Local arrays
      double precision, allocatable::dsgn(:),dlim(:),df(:),dcen(:)

      integer i, n
      double precision dlft, drgt, slop, dq1

      allocate (dsgn(ilo-2:ihi+2))
      allocate (dlim(ilo-2:ihi+2))
      allocate (  df(ilo-2:ihi+2))
      allocate (dcen(ilo-2:ihi+2))

      do n = 1, nv
!       if (n .ne. QPRES) then

            ! first compute Fromm slopes
            do i = ilo-2, ihi+2
                dlft = TWO*(q(i  ,n) - q(i-1,n))
                drgt = TWO*(q(i+1,n) - q(i  ,n))
                dcen(i) = FOURTH * (dlft+drgt)
                dsgn(i) = sign(ONE, dcen(i))
                slop = min( abs(dlft), abs(drgt) )
!                dlim(i) = cvmgp( slop, ZERO, dlft*drgt )
                if (dlft*drgt .ge. ZERO) then
                   dlim(i) = slop
                else
                   dlim(i) = ZERO
                endif
                df(i) = dsgn(i)*min( dlim(i), abs(dcen(i)) )
            enddo

            ! now limited fourth order slopes
            do i = ilo-1, ihi+1
                dq1 = FOUR3RD*dcen(i) - SIXTH*(df(i+1) + df(i-1))
                dq(i,n) = flatn(i)* &
                            dsgn(i)*min(dlim(i),abs(dq1))
            enddo
!       end if
      enddo

      deallocate (dsgn,dlim,df,dcen)

      end subroutine uslope

! :::
! ::: ------------------------------------------------------------------
! :::
      subroutine pslope(p,rho,flatn,qd_l1,qd_h1,dp,qpd_l1,qpd_h1, &
                        src,src_l1,src_h1,ilo,ihi,dx)

      use amrex_constants_module
      use meth_params_module, only: QU, QVAR

      implicit none

      integer ilo, ihi
      integer  qd_l1, qd_h1
      integer qpd_l1,qpd_h1
      integer src_l1,src_h1
      double precision, intent(in   ) ::      p( qd_l1: qd_h1)
      double precision, intent(in   ) ::    rho( qd_l1: qd_h1)
      double precision, intent(in   ) ::  flatn( qd_l1: qd_h1)
      double precision, intent(  out) ::     dp(qpd_l1:qpd_h1)
      double precision, intent(in   ) ::    src(src_l1:src_h1,QVAR)
      double precision, intent(in   ) ::  dx

!     Local arrays
      double precision, allocatable :: dsgn(:), dlim(:), df(:), dcen(:)

      integer          :: i
      double precision :: dlft, drgt, dp1

      allocate (dsgn(ilo-2:ihi+2))
      allocate (dlim(ilo-2:ihi+2))
      allocate (  df(ilo-2:ihi+2))
      allocate (dcen(ilo-2:ihi+2))

      ! first compute Fromm slopes
      do i = ilo-2, ihi+2
          dlft = p(i  ) - p(i-1)
          drgt = p(i+1) - p(i  )

          ! Here we subtract off (rho * acceleration) so as not to limit that part of the slope
          dlft = dlft - FOURTH * (rho(i)+rho(i-1))*(src(i,QU)+src(i-1,QU))*dx
          drgt = drgt - FOURTH * (rho(i)+rho(i+1))*(src(i,QU)+src(i+1,QU))*dx
!         dlft = dlft - rho(i)*src(i,QU)*dx
!         drgt = drgt - rho(i)*src(i,QU)*dx

          dcen(i) = HALF*(dlft+drgt)
          dsgn(i) = sign(ONE, dcen(i))

          if (dlft*drgt .ge. ZERO) then
             dlim(i) = TWO * min( abs(dlft), abs(drgt) )
          else
             dlim(i) = ZERO
          endif
          df(i) = dsgn(i)*min( dlim(i), abs(dcen(i)) )
      enddo

      if (ilo .eq. 0) then
        df(-1) = -df(0)
        df(-2) = -df(1)
      end if

      ! now limited fourth order slopes
      do i = ilo-1, ihi+1
          dp1 = FOUR3RD*dcen(i) - SIXTH*(df(i+1) + df(i-1))
          dp(i) = flatn(i)* &
                      dsgn(i)*min(dlim(i),abs(dp1))
          dp(i) = dp(i) + rho(i)*src(i,QU)*dx
      enddo

      ! Here we are assuming a symmetry boundary condition
      if (ilo .eq. 0) dp(-1) = -dp(0)

      deallocate (dsgn,dlim,df,dcen)

      end subroutine pslope

end module slope_module


!***********************************/
!	Name:Target格子をグローバル格子に登録する
!	Alias:RegisterIntoGlobal
!	Description:
!	Type:
!	Input:
!	Output:
!	Note:現状，面積の代わりにセル中心間距離の逆数を代入しているところに注意．さらに言えば，複数セル間に跨る要素はすべて中心が属する側に所属するものとして見なしている
!	Author:Akitaka Toyota
!	Date:2017.12.26
!	Update:
!	Other:
!***********************************/
    subroutine RegisterIntoGlobal(iGrid,GG,iGlobalCellNumber,Geom,CUV,iLoop,RIG)
    use StructVar_Mod
    use FrequentOperation
    use RegistVar_Mod4OMP
    implicit none

    integer, intent(in) :: iGrid
    type(GlobalGrid), intent(inout) :: GG
    integer, intent(inout) :: iGlobalCellNumber !なんと後で再利用する(内挿対象が見つからなくてG格子からの内蔵を行う際の登録部分で使う) !恐らく廃止
    type(Geometry), intent(inout) :: Geom
    type(CountUpVertex), intent(in) :: CUV

    integer, intent(inout) :: iLoop
    type(RegisterIntoGlobalWithOMP), intent(inout) :: RIG

    !type(DonorElement), pointer :: RIG%Temp
        !構造格子のデータの一部をGG%GASGにコピーして使う，というか前処理の段階でグローバル格子に対応するGG%GASGを作る

        !(非構造格子の座標r,Auxiliary格子の座標r0，構造格子負端からのセル数n，格子幅dxについて
        !r-r0 > n*dxなる関係があることから，nについて解くと以下のような式になる(※2次元用で書いたためzは常に固定値になる)

    !do iLoop = 0, 3 !セル中心+セル頂点に関するループ
    iLoop = 0
        !RIG%GlobalGridNum(1:2) = int((NSR%C%NextCoordsInG(iCell,1:2) - GG%GASG%Bound(1,1:2))/(GG%GASG%Width(1:2)))+1 !補助格子におけるセル中心位置
        call GetLocalNumber2D(CUV%TargetCoords(iLoop,1:2),GG%GASG%Width(1:2),GG%GASG%Bound(1,1:2),RIG%GlobalGridNum(1:2))
        RIG%GlobalGridNum(3) = 1

        !取扱いの利便性を上げるためグローバルセル番号(詳細は↓)に変換する．
        !(i,j,k) <=>!2D:(j-1)*(Lx)+i !3D:(k-1)*(Ly*Lx)+(j-1)*(jmax-1)+i

        iGlobalCellNumber = Local2Global(RIG%GlobalGridNum(1),RIG%GlobalGridNum(2),GG%GASG%CellNumber(1))

        !Global格子がLocal格子から参照された回数を記録 !このサブルーチンの外側で初期化しておく

        GG%GASG%ContentsAS2U(iGlobalCellNumber) = GG%GASG%ContentsAS2U(iGlobalCellNumber) + 1 !この場合Global 2 Localなので注意

        if(GG%GASG%ContentsAS2U(iGlobalCellNumber) == 1) then
            nullify(GG%GDE(iGlobalCellNumber)%DE) !リストの初期化
            Geom%Interpolated(RIG%GlobalGridNum(1),RIG%GlobalGridNum(2),1) = 1 !時間積分からの保護(globalを補間する格子はすべてn+1段階)
        end if
        !最後に構造格子に所属する非構造格子への対応を記録する

        !セル中心間距離
        !G格子のセル中心位置
        call GetCellCenterCoords(RIG%GlobalGridNum(1),RIG%GlobalGridNum(2),GG%GASG%Bound(1,1:2),GG%GASG%Width(1:2),RIG%CellCenterCoords(1:2))
        RIG%CellCenterCoords(3) = 0.0d0

        allocate(RIG%Temp) !新規ノードの確保
            RIG%Temp%Cell = CUV%iTargetNumber(0) !ノードへの記録
            RIG%Temp%Grid = iGrid
            RIG%Temp%SharedArea = 1.0d0/(sqrt(dot_product(&
                &   CUV%TargetCoords(iLoop,1:3)-RIG%CellCenterCoords(1:3),&
                &   CUV%TargetCoords(iLoop,1:3)-RIG%CellCenterCoords(1:3))))

            !if(iLoop == 0) then !セル中心のとき
            !    RIG%Temp%SharedArea = 0.4d0 * RIG%Temp%SharedArea !(セル中心が属する=2/5)
            !else !セル頂点のとき
            !    RIG%Temp%SharedArea = 0.2d0 * RIG%Temp%SharedArea !(セル中心が属する=1/5)
            !end if

            RIG%Temp%Next => GG%GDE(iGlobalCellNumber)%DE !前のノードへのリンク作成
            GG%GDE(iGlobalCellNumber)%DE => RIG%Temp !データの保存

    !end do

    return
    end subroutine RegisterIntoGlobal


#include "f_defs.h"

!!===================================================================
!!
!! Module:
!!
!!    gmap          Last Modified by Meng Wu (2020)
!!
!!     Find the index array and phases needed to map G-vectors for a
!!     wavefunction at one k-point to the corresponding wavefunction
!!     at a symmetry-related k-point.
!!
!!===================================================================

module gmap_m

  use global_m
  use misc_m

  implicit none

  private

  public :: gmap

  interface gmap
     module procedure dgmap, zgmap
  end interface gmap

contains

  subroutine dgmap(gvec, syms, ngk, itran, kgq, isortc, isorti, ind, phase)
    type (gspace), intent(in) :: gvec         ! uses gvec%components(:,isrtc(1:ngk)), and index_vec
    type (symmetry), intent(in) :: syms       ! uses syms%mtrx(:,:,itran) & syms%tnp(:,itran)
    integer, intent(in) :: ngk                ! number of g-vector entries in a wavefunction
    integer, intent(in) :: itran              ! index of transformation
    integer, intent(in) :: kgq(3)             ! an umklapp vector (i.e. integer 3-vector)
    integer, intent(in) :: isortc(:)          ! index array for R(q) (1:ngk)
    integer, intent(in) :: isorti(:)          ! inverse index array for q (1:gvec%ng)
    integer, intent(out) :: ind(:)            ! indices for the vectors inv(symm(itran))*(g+kgq) (ngk)
    real(DP), intent(out) :: phase(:)         ! exp(-i*(g+kgq).dot.syms%tnp(itran)) (ngk)

    PUSH_SUB(dgmap)

    call gmap_base( gvec, syms, ngk, itran, kgq, isortc, isorti, ind, dphase = phase)

    POP_SUB(dgmap)
    return
  end subroutine dgmap

  subroutine zgmap(gvec, syms, ngk, itran, kgq, isortc, isorti, ind, phase)
    type (gspace), intent(in) :: gvec         ! uses gvec%components(:,isrtc(1:ngk)), and index_vec
    type (symmetry), intent(in) :: syms       ! uses syms%mtrx(:,:,itran) & syms%tnp(:,itran)
    integer, intent(in) :: ngk                ! number of g-vector entries in a wavefunction
    integer, intent(in) :: itran              ! index of transformation
    integer, intent(in) :: kgq(3)             ! an umklapp vector (i.e. integer 3-vector)
    integer, intent(in) :: isortc(:)          ! index array for R(q) (1:ngk)
    integer, intent(in) :: isorti(:)          ! inverse index array for q (1:gvec%ng)
    integer, intent(out) :: ind(:)            ! indices for the vectors inv(symm(itran))*(g+kgq) (ngk)
    complex(DPC), intent(out) :: phase(:)     ! exp(-i*(g+kgq).dot.syms%tnp(itran)) (ngk)

    PUSH_SUB(zgmap)

    call gmap_base(gvec, syms, ngk, itran, kgq, isortc, isorti, ind, zphase = phase)

    POP_SUB(zgmap)
    return
  end subroutine zgmap

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

  !! gmap_base() allow ig_old exceed ngk, which is the largest index of ig_new
  subroutine gmap_base(gvec, syms, ngk, itran, kgq, isortc, isorti, ind, dphase, zphase)
    type (gspace), intent(in) :: gvec         ! uses gvec%components(:,isrtc(1:ngk)), and index_vec
    type (symmetry), intent(in) :: syms       ! uses syms%mtrx(:,:,itran) & syms%tnp(:,itran)
    integer, intent(in) :: ngk                ! number of g-vector entries in a wavefunction
    integer, intent(in) :: itran              ! index of transformation
    integer, intent(in) :: kgq(3)             ! an umklapp vector (i.e. integer 3-vector)
    integer, intent(in) :: isortc(:)          ! index array for R(q) (1:ngk)
    integer, intent(in) :: isorti(:)          ! inverse index array for q (1:gvec%ng)
    integer, intent(out) :: ind(:)            ! indices for the vectors inv(symm(itran))*(g+kgq) (ngk)
    real(DP),     optional, intent(out) :: dphase(:) ! exp(-i*(g+kgq).dot.syms%tnp(itran)) (ngk)
    complex(DPC), optional, intent(out) :: zphase(:) ! exp(-i*(g+kgq).dot.syms%tnp(itran)) (ngk)
    integer :: ig, kd(3), kadd, kgrad, kgrad1
    integer :: kg(3), kgr(3)
    integer, dimension(3,3) :: inv_mtrx_reci_int
    real(DP), dimension(3,3) :: inv_mtrx_reci, mtrx_reci, diff_inv_mtrx_reci
    logical :: flag_inv
    real(DP) :: fi
    PUSH_SUB(gmap_base)

    if(present(dphase) .and. present(zphase)) then
       call die("gmap: cannot pass both dphase and zphase")
    else if(.not. present(dphase) .and. .not. present(zphase)) then
       call die("gmap: must pass either dphase or zphase")
    endif

    if (ngk > gvec%ng) call die("gmap: ngk (wfn cutoff) is greater than gvec%ng (rho cutoff)")
    if (ubound(isorti, 1) < gvec%ng) call die("gmap: isorti size < gvec%ng")
    if (any(isorti(1:gvec%ng) > gvec%ng)) call die("gmap: isorti cannot be greater than gvec%ng.")
    if (ubound(isortc, 1) < ngk)      call die("gmap: isortc size < ngk")
    if (any(isortc(1:ngk) < 1))       call die("gmap: isortc cannot be less than 1.")
    if (any(isortc(1:ngk) > gvec%ng)) call die("gmap: isortc cannot be greater than ng.")
    if (ubound(gvec%index_vec, 1) /= gvec%nFFTgridpts) call die("gmap: gvec%index_vec has wrong size")
    if (any(gvec%index_vec(1:gvec%nFFTgridpts) < 0)) call die("gmap: index_vec cannot be less than 0")
    if (any(gvec%index_vec(1:gvec%nFFTgridpts) > gvec%ng)) call die("gmap: index_vec cannot be greater than ng")
    if(present(dphase)) then
       if(ubound(dphase, 1) < ngk) call die("gmap: dphase size < ngk")
    else
       if(ubound(zphase, 1) < ngk) call die("gmap: zphase size < ngk")
    endif
    if(ubound(ind, 1) < ngk) call die("gmap: ind size < ngk")

    mtrx_reci(1:3,1:3) = dble(syms%mtrx_reci(1:3,1:3,itran))
    call M33INV(mtrx_reci,inv_mtrx_reci,flag_inv)
    if (.not. flag_inv) then
       call die("gmap_2: mtrx_reci not invertible.", only_root_writes=.true.)
    endif

    inv_mtrx_reci_int(:,:) = NINT(inv_mtrx_reci(:,:))
    diff_inv_mtrx_reci(:,:) = DBLE(inv_mtrx_reci_int(:,:)) - inv_mtrx_reci(:,:)
    IF ( NORM2(diff_inv_mtrx_reci) > TOL_Zero ) THEN
       call die("gmap_2: inv_mtrx_reci not integer ", only_root_writes=.true.)
    ENDIF

    !! Loop over g-vectors in new wave function
    do ig = 1, ngk
       kg(1:3) = gvec%components(1:3, isortc(ig)) + kgq(1:3)
       kgr(1:3) = MATMUL(inv_mtrx_reci_int(1:3, 1:3), kg(1:3))
       kd(1:3) = kgr(1:3) + gvec%FFTgrid(1:3) / 2 + 1
       if (any(kd(1:3) .lt. 1 .or. kd(1:3) .gt. gvec%FFTgrid(1:3))) then
          call die('gmap: kd out of bounds')
       endif

       kadd = ((kd(1) - 1) * gvec%FFTgrid(2) + kd(2) - 1) * gvec%FFTgrid(3) + kd(3)
       !! gvec%index_vec(ig_FFT) = ig_gvec \in [1, gvec%ng]
       kgrad1 = gvec%index_vec(kadd)
       if (kgrad1 .lt. 1 .or. kgrad1 .gt. gvec%ng) then
          write(0,*) 'itran = ', itran, 'ig = ', ig, ', kadd = ', kadd, ', kgrad1 = ', kgrad1
          call die('gmap: G-vectors falling outside of the charge-density G-sphere')
       endif
       !! isorti(ig_gvec) = ig_old
       kgrad = isorti(kgrad1)
       !! kgrad can be 0 if kgrad1 is outside the cutoff of wfn_old!
       ind(ig) = kgrad
       fi = 2.0D0 * PI_D * DOT_PRODUCT(DBLE(gvec%components(1:3, isortc(ig))),syms%tnp(1:3,itran))
       if(present(zphase)) then
          zphase(ig) = DCMPLX(cos(fi), -sin(fi))
       else
          dphase(ig) = cos(fi)
          if(abs(abs(dphase(ig)) - 1.0D0) .gt. TOL_Small) then
             write(0,'(a,i8,a,f12.8,a)') 'phase(', ig, ') = ', dphase(ig), ' != +/- 1'
             call die("Illegal non-unity phase in gmap, error in fractional translation.")
          endif

          if(abs(sin(fi)) .gt. TOL_Small) then
             write(0,'(a,i8,a,f12.8)') 'Im phase(', ig, ') = ', -sin(fi)
             call die("Illegal complex phase in gmap, error in fractional translation.")
          endif
       endif
    enddo

    POP_SUB(gmap_base)
    return
  end subroutine gmap_base
end module gmap_m


!*******************************************************************
!                                                                  *
      SUBROUTINE RMEAJJ11(J1,J2,LL,S)
!                                                                  *
!   Written by  G. Gaigalas                                        *
!   Transform to fortran 90/95 by G. Gaigalas       December 2012  *
!   The last modification made by G. Gaigalas       October  2017  *
!                                                                  *
!*******************************************************************
!
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY: DOUBLE
      USE CONS_C,          ONLY: ZERO, HALF, EPS
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE rumtjj_I
      USE c0t5s_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER,      INTENT(IN)  :: LL, J1, J2
      REAL(DOUBLE), INTENT(OUT) :: S
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER      :: LQ, LV, LQS, LVS, J, J1S, N, INN
      REAL(DOUBLE) :: A1, A4, Q, QQ, QS, QM, QMS
!-----------------------------------------------
      S=ZERO
      CALL RUMTJJ(J1,LL,LQ,LV,J)
      CALL RUMTJJ(J2,LL,LQS,LVS,J1S)
      QQ=HALF
      N=2
      Q=HALF*DBLE(LQ)
      QS=HALF*DBLE(LQS)
      QM=-HALF*DBLE(HALF*(LL+1)-N)
      QMS=-HALF*DBLE(HALF*(LL+1)-(N-1))
      CALL C0T5S(QS,QMS,QQ,Q,QM,A4)
      IF(DABS(A4) < EPS) RETURN
      A1=DBLE(N*(LQ+1)*(J+1))
      S=DSQRT(A1)/A4
      INN=-N-1
      IF((INN/2)*2 /= INN)S=-S
      RETURN
      END SUBROUTINE RMEAJJ11


!==========================================================================
elemental function gsw_sp_from_sk (sk)
!==========================================================================
!
! Calculates Practical Salinity, SP, from SK
!
!  SK    : Knudsen Salinity                        [parts per thousand, ppt]
!
! gsw_sp_from_sk  : Practical Salinity                              [unitless]
!--------------------------------------------------------------------------

use gsw_mod_teos10_constants, only : gsw_soncl

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sk

real (r8) :: gsw_sp_from_sk

gsw_sp_from_sk = (sk - 0.03_r8)*(gsw_soncl/1.805_r8)

return
end function

!--------------------------------------------------------------------------


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2015 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine fcrit(time,t,a,b,ze,d,dd,h1,h2,h3,h4,func,funcp)
!
      implicit none
!
      real*8 time,t,a,b,ze,d,dd,h1,h2,h3,h4,fexp,func,funcp
!
      fexp=dexp(-h1*t)
!
!     function
!
      func=((a+b*time)*(-t*h2-h3)-b*(-t*t*h2-2.d0*t*h3-2.d0*h4))*fexp
!
!     derivative of the function
!
      funcp=((a+b*time)*t-b*(h3+t*h2+t*t))*fexp
!
      return
      end


subroutine atan2q(y,x,v)

  real(kind=16), intent(in) :: y
  real(kind=16), intent(in) :: x
  real(kind=16), intent(out) :: v

  v = qatan2(y,x)
end


c-----------------------------------------------------------------------
c
c     Spalart-Allmaras turbulence model constants
c
c-----------------------------------------------------------------------
      module turbSA

      real*8, allocatable ::  d2wall(:)
      real*8, allocatable ::  wnrm(:,:)
      integer, allocatable :: otwn(:)
      real*8  saCb1, saCb2, saCw1, saCw2, saCw3, saCv1, saSigma,
     &        saKappa, saKappaP2Inv, saCv2P3, saCw3P6, saSigmaInv
      integer, allocatable :: sidmapg(:) ! list of all surfID's, low to high

      parameter (
     &     saCb1        = 0.1355d0,
     &     saCb2        = 0.622d0,
     &     saCw1        = 3.239067817d0,
     &     saCw2        = 0.3d0,
     &     saCw3        = 2.0d0,
     &     saKappa      = 0.41d0,
     &     saSigma      = 0.666666666666666667d0,
     &     saCv1        = 7.1d0,
     &     saKappaP2Inv = 5.94883997620464d0,
     &     saCv1P3      = 3.579109999999999d+02,
     &     saCw3P6      = 64.0d0,
     &     saSigmaInv   = 1.50d0
     &     )

      end module

c-----------------------------------------------------------------------
c
c     Initialize: compute the distance to the nearest wall for
c     each vertex in the mesh.
c
c     Michael Yaworski (fall 1998)
c
c-----------------------------------------------------------------------
      subroutine initTurb( x )

      use     pointer_data
      use     turbSA
      include "common.h"
      include "mpif.h"

      character*20 fname1,  fmt1
      real*8   x(numnp,nsd)
      integer  nwall(numpe),      idisp(numpe)
      character*5  cname
      real*8, allocatable :: xwi(:,:,:), xw(:,:,:)

!MR CHANGE
      integer :: ierr
      integer :: numparts, nfile, itmp2, id2wall, itwo, ifoundd2wall
      integer iarray(10)
      character*255 :: fnamer, fname2, temp2
      character*64 :: temp1
!MR CHANGE END

      allocate ( d2wall(numnp) )

!MR CHANGE
      if(myrank.eq.master) then
        write (*,*) 'entering initTurb'
      endif
      call MPI_BARRIER(MPI_COMM_WORLD,ierr)

      ! First we try to read the d2wall field from either the restart files or the d2wall files
      call read_d2wall(myrank,numnp,d2wall,ifoundd2wall)
!MR CHANGE END

      if(ifoundd2wall.eq.0) then   ! d2wall was not found so calculate the distance
        if(myrank.eq.master) then
          write (*,*) 'Computing the d2wall field'
        endif
c
c   hard code trip point until we are sure it is worth doing
c

c
c.... Count the welts (wall-elements)
c
         nwalli=0
         do iblk = 1, nelblb    ! loop over boundary elt blocks
            npro = lcblkb(1,iblk+1) - lcblkb(1,iblk)
            do j = 1, npro
               if(btest(miBCB(iblk)%p(j,1),4)) nwalli=nwalli+1
            enddo
         enddo
c
c.... Create wallnode-coord list for welts on processor
c
         if (nwalli.eq.0) nwalli=1 !  patch for mpi's lack of imagination
         allocate (xwi(nwalli,nenb+1,nsd))
         xwi = 1.0d32
         xwi(:,nenb+1,:)=zero
         nwalli = 0
         do iblk = 1, nelblb    ! loop over boundary elt blocks
c
            iel    = lcblkb(1,iblk)
            nenbl  = lcblkb(6,iblk) ! no. of vertices per bdry. face
            npro   = lcblkb(1,iblk+1) - iel
c
            do j = 1, npro      ! loop over belts in this blk
               if(btest(miBCB(iblk)%p(j,1),4)) then
                  nwalli=nwalli+1
c assemble local coord list
                  do node = 1, nenbl
                     xwi(nwalli,node,1:3)=x(mienb(iblk)%p(j,node),:)
                  enddo
c put the centroid coordinates in the last slot
                  do node = 1, nenbl
                     xwi(nwalli,nenb+1,:)=xwi(nwalli,nenb+1,:)
     &                    +xwi(nwalli,node,:)
                  enddo
                  xwi(nwalli,nenb+1,:)=xwi(nwalli,nenb+1,:)/nenbl
c
               endif
            enddo               ! loop over belts in this blk
c
         enddo                  ! loop over boundary elt blocks
c
         if (nwalli.eq.0) xwi=1.0e32 ! fix for mpi's lack of imagination
         if (nwalli.eq.0) nwalli=1 !  patch for mpi's lack of imagination
c
c  Pool "number of welts" info from all processors
c
cMPI_ALLGATHER(sendbuf,sendcount,sendtype,recvbuf,recvcount,recvtype,comm)
c[ IN sendbuf] starting address of send buffer (choice)
c[ IN sendcount] number of elements in send buffer (integer)
c[ IN sendtype] data type of send buffer elements (handle)
c[ OUT recvbuf] address of receive buffer (choice)
c[ IN recvcount] number of elements received from any process (integer)
c[ IN recvtype] data type of receive buffer elements (handle)
c[ IN comm] communicator (handle)
         if (numpe.gt.1) then   ! multiple processors
c write the number of wall elts on the jth processor to slot j of nwall
            call MPI_ALLGATHER(nwalli,1,MPI_INTEGER,nwall,1,
     &          MPI_INTEGER,MPI_COMM_WORLD,ierr)
c count up the total number of wall elts among all processes
            nwallt=0
            do j=1,numpe
               nwallt=nwallt+nwall(j)
            enddo
         else                   ! single processor
c the local information is the global information for single-processor
            nwall=nwalli
            nwallt=nwalli
         endif                  ! if-else for multiple processors
c
c  Make all-processor wallnode-coord collage
c
         allocate (xw(nwallt,nenb+1,nsd))
         if (numpe.gt.1) then   ! multiple processors
c we will gather coordinates from local on-proc sets to a global set
c we will stack each processor's coordinate list atop that of the
c previous processor.  If the coordinate list for processor i is
c called xwi, then our global coordinate list xw will look like this:
c ---------------------------------------------------------------
c | xw1            | xw2                | xw3        |   ...    |
c ---------------------------------------------------------------
c  <---nwall(1)---> <-----nwall(2)-----> <-nwall(3)->
c  <------------------------nwallt-----------------------...---->
c To accomplish this with MPI, we use MPI_ALLGATHERV, summarized as:
cMPI_ALLGATHERV(sendbuf,sendcount,sendtype,recvbuf,recvcount,disp,recvtype,comm)
c[ IN sendbuf] starting address of send buffer (choice)
c[ IN sendcount] number of elements in send buffer (integer)
c[ IN sendtype] data type of send buffer elements (handle)
c[ OUT recvbuf] address of receive buffer (choice)
c[ IN recvcount] number of elements received from any process (integer)
c[ IN disp] displacement array
c[ IN recvtype] data type of receive buffer elements (handle)
c[ IN comm] communicator (handle)
c The displacement array disp is an array of integers in which the jth
c entry indicates which slot of xw marks beginning of xwj
c So, first we will build this displacement array
            idisp(:)=0 ! starting with zero, since MPI likes C-numbering
            do j=2,numpe
               idisp(j)=idisp(j-1)+nwall(j-1) ! see diagram above
            enddo
c Now, we gather the data one slice at a time (1:nwalli)
            do j=1,nenb+1
               do k=1,nsd
                  call MPI_ALLGATHERV(xwi(:,j,k),nwalli,
     &                 MPI_DOUBLE_PRECISION,xw(:,j,k),nwall,idisp,
     &                 MPI_DOUBLE_PRECISION,MPI_COMM_WORLD,ierr)
               enddo
            enddo
         else                   ! single-processor
c global data is local data in single processor case
            xw=xwi
         endif

c
c  For each point, loop over wall nodes and calculate distance;
c  save the distance in this node's position of d2wall if it's
c  shorter than currently stored distance
c
         d2wall=1.0e32
         do i=1,numnp
            do j=1, nwallt
               do k=1,nenb+1
                  distance =  ( x(i,1) - xw(j,k,1) )**2
     &                 +( x(i,2) - xw(j,k,2) )**2
     &                 +( x(i,3) - xw(j,k,3) )**2
                  if ( d2wall(i).gt.distance ) d2wall(i) = distance
               enddo
            enddo
         enddo
         d2wall=sqrt(d2wall)
c
         deallocate(xwi)
         deallocate(xw)
c
c.... write d2wall to a file so we don't have to do this again
c

!MR CHANGE #Fix this with SyncIO!!!!!
!         write (fmt1,"('(''d2wall.'',i',i1,',1x)')") 1
!         write (fname1,fmt1) 0
!         fname1 = trim(fname1) // cname(myrank+1)
!         if(myrank.eq.master) write (*,*) 'Writing dist file : ', fname1
!         open (unit=72, file=fname1, status='unknown',
!     &                                    form='unformatted', err=996)
!
!         write (72) d2wall
!         close (72)

          call write_d2wall(myrank,numnp,d2wall) !See new_interface.c

!MR CHANGE END

c         write(*,*) "make sure to: echo 0 > distcalc.dat"
c         call MPI_BARRIER (MPI_COMM_WORLD,ierr)
c         call error ('distcalc','complete',0)
      endif

!MR CHANGE
      call MPI_BARRIER(MPI_COMM_WORLD,ierr)
      if(myrank.eq.master) then
        write (*,*) 'leaving initTurb'
      endif
!MR CHANGE

      return
995     call error ('d2wall  ','opening ', 72)
996     call error ('d2wall  ','opening ', 72)

      end subroutine


C Copyright (C) 2002, Carnegie Mellon University and others.
C All Rights Reserved.
C This code is published under the Common Public License.

C ============================================================================
C
      SUBROUTINE APPSLN(T, NZ, NY, NU, NELE, NCOL, TI, X,
     1     ZVAL, DZVAL, YVAL, UVAL)
C !DEC$ ATTRIBUTES DLLEXPORT :: APPSLN
C
C     $Id: appsln.f,v 1.1 2002/05/02 18:52:15 andreasw Exp $
C
C     Subroutine for evaluating the DAE variables at given time T
C
C     Author:  Andreas Waechter
C              c/o Group of Larry Biegler
C              Department of Chemical Engineering
C              Carnegie Mellon University
C              Pittsburgh, PA
C
C     Version 1.0    ( 10-30-00 )
C
C     Description:
C     ============
C
C       evaluate Z, Y and U on time T based interpolation;
C          results in ZVAL, YVAL, UVAL
C
C     Parameters:
C
C     T        Input    time on which variable are to evaluated
C     NZ       Input    number of differential variables
C     NY       Input    number of algebraic variables
C     NU       Input    number of control variables
C     NELE     Input    number of elements
C     NCOL     Input    number of collocation points
C     TI       Input    boundaries of finite elements
C     X        Input    coefficients of collocation polynomials
C                         (for ordering see dae2nlp.f)
C     ZVAL     Output   value of differential variables at T
C     DZVAL    Output   value of derivative of differential variables at T
C     YVAL     Output   value of algebraic variables at T
C     UVAL     Output   value of control variables at T
C
      implicit none
      double precision T
      integer NZ, NY, NU, NELE, NCOL
      double precision TI(NELE+1)
      double precision X(NZ + NELE*(NCOL*(NZ+NY+NU)+NZ))
      double precision ZVAL(NZ)
      double precision DZVAL(NZ)
      double precision YVAL(NY)
      double precision UVAL(NU)

      include 'DAE2NLP.INC'
C !DEC$ ATTRIBUTES DLLEXPORT :: /DAENLP/

      integer iele, il, iu, lw, lu
      double precision theta(7), omega(7), dummy
C
C     Find element in which T is located (binary search)
C
      if( TI(2).ge.T ) then
         iele = 1
      elseif( TI(NELE).lt.T ) then
         iele = NELE
      else
         il = 2
         iu = NELE
 100     continue
         if( iu-il.gt.1 ) then
            iele = il+(iu-il)/2
            if( TI(iele).lt.T ) then
               il = IELE
            else
               iu = iele
            endif
            goto 100
         endif
         iele = il
      endif
C
C     Compute values
C
      lw = 1 + (iele-1)*(NCOL*(NZ+NY)+NZ)
      lu = 1 + NELE*(NCOL*(NZ+NY)+NZ) + NZ + (iele-1)*NCOL*NU
      call APPROX (3, NZ, NY, NU, NELE, NCOL, COEF, X(lw), X(lu), TI,
     1     iele, T, omega, theta, ZVAL, YVAL, UVAL)
      call APPROX (4, NZ, NY, NU, NELE, NCOL, COEF, X(lw), X(lu), TI,
     1     iele, T, omega, theta, DZVAL, dummy ,dummy)
C
C     That's it
C
      return
      end


      double precision function enorm(e,kvec)
************************************************************************
*
*   ENORM -- Error norm.
*
************************************************************************
      include "parameters.h"

      integer nnod,nelt
      common /mfe010/ nnod,nelt

      double precision ptol,rtol,dx
      common /mfe060/ ptol(nepn),rtol /mfe061/ dx(mnod)

      integer kvec,j,k
      double precision e(nepn,*)

*     Absolute norm on each unknown.
      enorm = 0.d0
      do 10 k=1,nepn
      do 10 j=1,nnod
   10 enorm = max( enorm, abs(e(k,j))/ptol(k) )

*     Relative norm on the element lengths.
      do 20 j=1,nelt
   20 enorm = max( enorm, abs(e(nepn,j+1)-e(nepn,j))/(dx(j)*rtol) )

      return
      end


!================================================================================
!  Subroutine that rescales the current velocities.  The rescales velocity
!  will have the spectrum that is defined in the input file via parameters
!  isp_type (spectrum type) and peak_wavenum (peak wavenumber).
!
!  The program is copies from a part of init_velocity.f90.  Some time in the
!  future we should make it one routine that is called in init_velocity.
!
!  Time-stamp: <2010-01-25 17:01:55 (chumakov)>
!================================================================================

subroutine velocity_rescale

    use m_openmpi
    use m_parameters
    use m_io
    use m_fields
    use x_fftw

    implicit none

    integer :: i, j, k, n

    real, allocatable   :: rr(:)
    real*8, allocatable :: e_spec(:), e_spec1(:)
    integer*8, allocatable :: hits(:), hits1(:)

    integer   :: n_shell
    real*8    :: sc_rad1, sc_rad2

    real*8 :: wmag, wmag2, ratio, fac

    ! if Taylor-Green, return
    if (isp_type .eq. -1) return

!================================================================================
    allocate (e_spec(kmax), e_spec1(kmax), rr(nx + 2), hits(kmax), hits1(kmax), stat=ierr)
    if (ierr .ne. 0) stop "cannot allocate the init_velocity arrays"

    write (out, *) 'Rescaling the velocities'
    call flush (out)

!-------------------------------------------------------------------------------
!     Making the spectrum to be what is prescribed in the input file <...>.in
!-------------------------------------------------------------------------------

    ! --- first get the energy spectrum (copied from m_stat.f90)

    ! need this normalization factor because the FFT is unnormalized
    fac = one/real(nx*ny*nz_all)**2

    ! zeroing out the arrays
    e_spec1 = zip
    e_spec = zip
    hits = 0
    hits1 = 0

    ! finding the total energy in each shell and number of hits in each shell
    ! storing them in arrays hits1 and e_spec1
    do k = 1, nz
        do j = 1, ny
            do i = 1, nx

                n_shell = nint(sqrt(real(akx(i)**2 + aky(k)**2 + akz(j)**2, 4)))
                if (n_shell .gt. 0 .and. n_shell .le. kmax) then
                    hits1(n_shell) = hits1(n_shell) + 1
                    e_spec1(n_shell) = e_spec1(n_shell) + &
                                       fac*(fields(i, j, k, 1)**2 + fields(i, j, k, 2)**2 + fields(i, j, k, 3)**2)
                end if
            end do
        end do
    end do

    ! reducing the number of hits and energy to two arrays on master node
    count = kmax
    call MPI_REDUCE(hits1, hits, count, MPI_INTEGER8, MPI_SUM, 0, MPI_COMM_TASK, mpi_err)
    count = kmax
    call MPI_REDUCE(e_spec1, e_spec, count, MPI_REAL8, MPI_SUM, 0, MPI_COMM_TASK, mpi_err)

    ! now the master node counts the energy density in each shell
    if (myid .eq. 0) then
        fac = four/three*PI/two
        do k = 1, kmax
            sc_rad1 = real(k, 8) + half
            sc_rad2 = real(k, 8) - half
            if (k .eq. 1) sc_rad2 = 0.d0
            if (hits(k) .gt. 0) then
                e_spec(k) = e_spec(k)/hits(k)*fac*(sc_rad1**3 - sc_rad2**3)
            else
                e_spec(k) = zip
            end if
        end do
    end if

    ! broadcasting the spectrum
    count = kmax
    call MPI_BCAST(e_spec, count, MPI_REAL8, 0, MPI_COMM_TASK, mpi_err)

!-------------------------------------------------------------------------------
!  Now make the spectrum to be as desired
!-------------------------------------------------------------------------------

    ! first, define the desired spectrum
    do k = 1, kmax

        wmag = real(k, 8)
        ratio = wmag/peak_wavenum

        if (isp_type .eq. 0) then
            ! Plain Kolmogorov spectrum
            e_spec1(k) = wmag**(-5.d0/3.d0)

        else if (isp_type .eq. 1) then
            ! Exponential spectrum
            e_spec1(k) = ratio**3/peak_wavenum*exp(-3.0D0*ratio)

        else if (isp_type .eq. 3) then
            ! Von Karman spectrum
            fac = two*PI*ratio
            e_spec1(k) = fac**4/(one + fac**2)**3

        else
            write (out, *) "ERROR: WRONG INITIAL SPECTRUM TYPE: ", isp_type
            call flush (out)
            stop

        end if
    end do

!  normalize it so it has the unit total energy
    e_spec1 = e_spec1/sum(e_spec1(1:kmax))

    ! now go over all Fourier shells and multiply the velocities in a shell by
    ! the sqrt of ratio of the resired to the current spectrum
    do k = 1, nz
        do j = 1, ny
            do i = 1, nx + 2

                n_shell = nint(sqrt(real(akx(i)**2 + aky(k)**2 + akz(j)**2, 4)))
                if (n_shell .gt. 0 .and. n_shell .le. kmax .and. e_spec(n_shell) .gt. zip) then
                    fields(i, j, k, 1:3) = fields(i, j, k, 1:3)*sqrt(e_spec1(n_shell)/e_spec(n_shell))
                else
                    fields(i, j, k, 1:3) = zip
                end if

            end do
        end do
    end do

    write (out, *) "Rescaled the velocities."
    call flush (out)

    ! deallocate work arrays
    deallocate (e_spec, e_spec1, rr, hits, hits1, stat=ierr)

    return
end subroutine velocity_rescale


	SUBROUTINE SH_RNDT  ( ireptyp, time, dattim, ihhmm, iret)
C************************************************************************
C* SH_RNDT								*
C*									*
C* Takes input character GEMPAK time YYMMDD/HHMM and rounds the minutes *
C* up.  For .A & .B reports (ireptyp=1,2), time is rounded to the next 	*
C* hour, if MM is greater than or equal to 45 minutes.  For .E reports  *
C* (ireptyp=3), time is rounded up to the nearest 15 minutes		*
C*									*
C* Returns rounded time in GEMPAK time format YYMMDD/HHMM.  Also        *
C* original HHMM field as an integer.  This can be used as the station  *
C* time.								*
C*									*
C* SH_RNDT  ( IREPTYP, TIME, DATTIM, IHHMM, IRET )			*
C*									*
C* Input parameters:							*
C*	IREPTYP	 	INTEGER		Report type			*
C*	TIME	 	CHAR*12		YYMMDD/HHMM			*
C*									*
C* Output parameters:							*
C*      DATTIM          CHAR*12         Rounded time YYMMDD/HHMM        *
C*      IHHMM           INTEGER         Original HHMM                   *
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 -1 = invalid time		*
C**									*
C* Log:									*
C* P.Bruehl/NWS 	 6/98	Based on SH_RTIM                      	*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	INTEGER		ihhmm, ireptyp
	CHARACTER*(12)	time, dattim
C*
	LOGICAL		addday
C*
	INTEGER		idtar (5)
	EQUIVALENCE	( idtar (1), iyear ), ( idtar (2), imnth ),
     +			( idtar (3), iday  ), ( idtar (4), ihour ),
     +			( idtar (5), imin  )
C*
C------------------------------------------------------------------------
	iret   = 0
	addday = .false.
C
C* Convert character YYMMDD/HHMM to 5 integer array:
C* idtar(1)=YYYY, idtar(2)=MM, idtar(3)=DD, idtar(4)=HH idtar(5)=MM
C
        CALL TI_CTOI ( time, idtar, iret )
        IF ( iret .ne. 0 ) THEN
           RETURN
        ENDIF
C
C* Store original HHMM as integer
C
        ihhmm = (ihour * 100) + imin
C
C* Round the time
C
        IF ( ireptyp .eq. 3 ) THEN
C
C*      .E report - round to 15 minutes
C
          IF ( imin .eq. 0 ) THEN
             imin = 00
          ELSE IF ( imin .le. 15 ) THEN
             imin = 15
          ELSE IF ( imin .le. 30 ) THEN
             imin = 30
          ELSE IF ( imin .le. 45 ) THEN
             imin = 45
          ELSE
             imin = 00
	     ihour = ihour + 1
      	     IF  ( ihour .ge. 24 )  THEN
	        ihour = ihour - 24
	        addday = .true.
	     END IF
           ENDIF

        ELSE
C
C*      .A or .B report - round to hour
C
         IF  ( imin .ge. 45 )  THEN
	  ihour = ihour + 1
	  IF  ( ihour .ge. 24 )  THEN
	     ihour = ihour - 24
	     addday = .true.
	  END IF
 	 END IF
         imin = 00

        ENDIF
C
C
C* Add day if necessary.
C
        IF  ( addday )  CALL TI_ADDD  ( idtar, idtar, iret )
        IF ( iret .ne. 0 ) THEN
           RETURN
        ENDIF
C
C*	    Convert back to a GEMPAK time.
C
	CALL TI_ITOC  ( idtar, dattim, iret )
C*
	RETURN
	END


C$Procedure      WNDIFD ( Difference two DP windows )

      SUBROUTINE WNDIFD ( A, B, C )

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

      INTEGER               LBCELL
      PARAMETER           ( LBCELL = -5 )

      DOUBLE PRECISION      A        ( LBCELL:* )
      DOUBLE PRECISION      B        ( LBCELL:* )
      DOUBLE PRECISION      C        ( LBCELL:* )

C$ Brief_I/O
C
C      VARIABLE  I/O  DESCRIPTION
C      --------  ---  --------------------------------------------------
C      A,
C      B          I   Input windows.
C      C          I   Difference of A and B.
C
C$ Detailed_Input
C
C      A,
C      B           are windows, each of which contains zero or more
C                  intervals.
C
C$ Detailed_Output
C
C      C           is the output window, containing the difference
C                  of A and B---every point contained in A, but not
C                  contained in B.
C
C                  C must be distinct from both A and B.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C      1. If the difference of the two windows results in an excess of
C         elements, the error SPICE(WINDOWEXCESS) is signalled.
C
C$ Files
C
C      None.
C
C$ Particulars
C
C      Mathematically, the difference of two windows contains every
C      point contained in the first window but not contained in the
C      second window.
C
C      Fortran offers no satisfactory floating point representation
C      of open intervals. Thus, for floating point windows we must
C      return the closure of the set theoretical difference: that is,
C      the difference plus the endpoints of the first window that are
C      contained in the second window.
C
C$ Examples
C
C      Let A contain the intervals
C
C            [ 1, 3 ]  [ 7, 11 ]  [ 23, 27 ]
C
C      and B contain the intervals
C
C            [ 2, 4 ]  [ 8, 10 ]  [ 16, 18 ]
C
C      Then the difference of A and B contains the intervals
C
C            [ 1, 2 ]  [ 7, 8 ]  [ 10, 11 ]  [ 23, 27 ]
C
C$ Restrictions
C
C      None.
C
C$ Literature_References
C
C      None.
C
C$ Author_and_Institution
C
C      H.A. Neilan     (JPL)
C      W.L. Taber      (JPL)
C      I.M. Underwood  (JPL)
C
C$ Version
C
C-     SPICELIB Version 2.0.0, 16-SEP-1998 (WLT)
C
C         The previous version did not work when removing
C         singletons.  This has been corrected.
C
C-     SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C         Comment section for permuted index source lines was added
C         following the header.
C
C-     SPICELIB Version 1.0.0, 31-JAN-1990 (WLT) (IMU)
C
C-&

C$ Index_Entries
C
C     difference two d.p. windows
C
C-&

C$ Revisions
C
C-     Beta Version 1.1.0, 27-FEB-1989  (HAN)
C
C         Due to the calling sequence and functionality changes
C         in the routine EXCESS, the method of signalling an
C         excess of elements needed to be changed.
C
C-&

C
C     SPICELIB functions
C
      INTEGER               CARDD
      INTEGER               SIZED
      LOGICAL               RETURN

C
C     Local variables
C
      INTEGER               ACARD
      INTEGER               BCARD
      INTEGER               CSIZE

      INTEGER               APB
      INTEGER               APE
      INTEGER               BPB
      INTEGER               BPE
      INTEGER               PUT
      DOUBLE PRECISION      F
      DOUBLE PRECISION      L
      INTEGER               NEEDED

      INTEGER               OVER

      LOGICAL               KEEP
      LOGICAL               UNRSLV

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      END IF

      CALL CHKIN ( 'WNDIFD' )

C
C     Find the cardinality of the input windows, and the allowed size
C     of the output window. Also, save the size of the second window.
C
      ACARD = CARDD ( A )
      BCARD = CARDD ( B )
      CSIZE = SIZED ( C )
      OVER  = 0

C
C     Empty out the output window.
C
      CALL SSIZED ( CSIZE, C )

C
C     Let's handle the pathological cases first.
C
      IF ( BCARD .EQ. 0 ) THEN
         CALL COPYD ( A, C )
         CALL CHKOUT ( 'WNDIFD' )
         RETURN
      ELSE IF ( ACARD .EQ. 0 ) THEN
         CALL CHKOUT ( 'WNDIFD' )
         RETURN
      END IF

C
C     Now get pointers to the first intervals of A and B.
C
      APB = 1
      APE = 2
      BPB = 1
      BPE = 2
      PUT = 1
C
C     As long as the endpointer for A is less than the cardinality
C     of A we need to examine intervals and decide how much of
C     them to keep in C.
C
      DO WHILE ( APE .LE. ACARD )
C
C        We will work with the interval [F,L] which starts out
C        as the next interval of A.  We modify it below as required
C        when subtracting out intervals of B.
C
         F      = A(APB)
         L      = A(APE)
C
C        Right now we have not resolved whether to keep the interval
C        [F,L], but until we know better we assume it is a keeper.
C
         UNRSLV =  BPE .LE. BCARD
         KEEP   = .TRUE.

         DO WHILE ( UNRSLV )

            IF ( L .LT. B(BPB) ) THEN
C
C              The interval [F,L] is before the next interval of B, we
C              have resolved what to do with this one.   It is a
C              keeper.
C
               UNRSLV = .FALSE.

            ELSE IF ( F .GT. B(BPE) ) THEN
C
C              [F,L] is after the end of the current interval in B,
C              we need to look at the next interval of B
C
               BPB    = BPB + 2
               BPE    = BPE + 2
               UNRSLV = BPE .LE. BCARD

            ELSE
C
C              There is some overlap between the current interval
C              of B and the current interval of A. There are
C              several possibilities
C
C              1) The current interval of A is contained in the
C                 current interval of B (This includes singleton
C                 intervals in A). We just mark [F,L] so that it
C                 won't be kept.  We have fully resolved what to
C                 do with [F,L].
C
C              2) The interval from B overlaps at the beginning
C                 of the interval of A
C
C                 B interval [......]
C                 A interval     [............]
C                 result of A-B     [.........]
C
C                 In this case we need to shrink the interval [F,L]
C                 but we have not resolved how much of the result
C                 to keep.
C
C              3) The interval from B falls inside the current
C                 interval [F,L]
C
C                 B interval        [......]
C                 A interval     [............]
C                 result of A-B  [..]      [..]
C
C                 If the interval from B is not a singleton, we store
C                 the first part of [F,L] in C and then set [F,L] to
C                 be the right interval which is still not resolved.
C
C                 If the B interval is a singleton we can ignore ignore
C                 it.  But we have not resolved what to do about
C                 [F,L], we need to look at the next interval of B.
C

C
C              4) The interval from B overlaps at the ending
C                 of the interval of A
C
C                 B interval          [......]
C                 A interval     [......]
C                 result of A-B  [....]
C
C                 We need to shrink [F,L]. In this case we know we can
C                 keep all of what's left because all other intervals
C                 of B are to the right of [F,L]
C
               IF (       B(BPB) .LE. F
     .              .AND. L      .LE. B(BPE) ) THEN
C
C                 Case 1 above
C
                  KEEP   = .FALSE.
                  UNRSLV = .FALSE.

               ELSE IF ( B(BPB) .LE. F ) THEN
C
C                 Case 2 above
C
                  F      = B(BPE)
                  BPB    = BPB+2
                  BPE    = BPE+2
                  UNRSLV = BPE .LE. BCARD

               ELSE IF (      F      .LE. B(BPB)
     .                  .AND. L      .GE. B(BPE)
     .                  .AND. B(BPB) .LT. B(BPE) ) THEN
C
C                 Case 3 above (non-singleton interval of B).
C

                  IF ( PUT .LT. CSIZE ) THEN
                     C(PUT)   = F
                     C(PUT+1) = B(BPB)

                     CALL SCARDD ( PUT+1, C )

                     PUT      = PUT + 2
                  ELSE
                     OVER = OVER + 2
                  END IF

                  F      = B(BPE)
C
C                 If the interval from B contained L, we will not
C                 want to be keeping the singleton [F,L].
C
                  IF ( F .EQ. L ) THEN
                     KEEP   = .FALSE.
                     UNRSLV = .FALSE.
                  END IF

                  BPB    = BPB + 2
                  BPE    = BPE + 2
                  UNRSLV = UNRSLV .AND. BPE .LE. BCARD

               ELSE IF (      F      .LE. B(BPB)
     .                  .AND. L      .GE. B(BPE)
     .                  .AND. B(BPB) .EQ. B(BPE) ) THEN
C
C                 Case 3 above (singleton interval of B).
C
                  BPB    = BPB + 2
                  BPE    = BPE + 2
                  UNRSLV = BPE .LE. BCARD

               ELSE
C
C                 Case 4 above
C
                  L      =  B(BPB)
                  UNRSLV = .FALSE.

               END IF

            END IF

         END DO

C
C        If there is anything to keep in C, put it there.
C
         IF ( KEEP ) THEN
C
C           Make sure there is sufficient room to do the putting.
C
            IF ( PUT .LT. CSIZE ) THEN
               C(PUT)   = F
               C(PUT+1) = L
               CALL SCARDD ( PUT+1, C )
               PUT      = PUT + 2
            ELSE
               OVER = OVER + 2
            END IF

         END IF
C
C        Move the pointers in A to the next interval.
C
         APB = APB + 2
         APE = APE + 2

      END DO

C
C     We've examined all of the intervals of A and B, but if we
C     didn't actually store all of the difference, signal an error.
C
      IF ( OVER .GT. 0 ) THEN

         NEEDED = OVER + CSIZE

         CALL SETMSG ( 'The output window did not have '
     .   //            'sufficient room to contain the result of '
     .   //            'the window difference.  It has room for '
     .   //            '# endpoints, but # were needed to '
     .   //            'describe the difference. ' )

         CALL ERRINT ( '#', CSIZE  )
         CALL ERRINT ( '#', NEEDED )
         CALL SIGERR ( 'SPICE(WINDOWEXCESS)'  )

      END IF

      CALL CHKOUT ( 'WNDIFD' )

      RETURN
      END