!
! define some constants
!
 module constants
  include 'cts_mprec.h'
  implicit none
  private
  public root3,pi,lambda,sigma,c0,c1,ci,cexp1,cexp2,cexp3,cexp4
  public cexpk1,tau11,tau12,my_tiny
!
  interface root3
    module procedure dp_root3
    module procedure mp_root3
  end interface!root3
!
  interface pi
    module procedure dp_pi
    module procedure mp_pi
  end interface!pi
!
  interface lambda
    module procedure dp_lambda
    module procedure mp_lambda
  end interface!lambda
!
  interface sigma
    module procedure dp_sigma
    module procedure mp_sigma
  end interface!sigma
!
  interface c0
    module procedure dp_c0
    module procedure mp_c0
  end interface!c0
!
  interface c1
    module procedure dp_c1
    module procedure mp_c1
  end interface!c1
!
  interface ci
    module procedure dp_ci
    module procedure mp_ci
  end interface!ci
!
  interface cexp1
    module procedure dp_cexp1
    module procedure mp_cexp1
  end interface!cexp1
!
  interface cexp2
    module procedure dp_cexp2
    module procedure mp_cexp2
  end interface!cexp2
!
  interface cexp3
    module procedure dp_cexp3
    module procedure mp_cexp3
  end interface!cexp3
!
  interface cexp4
    module procedure dp_cexp4
    module procedure mp_cexp4
  end interface!cexp4
!
  interface cexpk1
    module procedure dp_cexpk1
    module procedure mp_cexpk1
  end interface!cexpk1
!
  interface tau11
    module procedure dp_tau11
    module procedure mp_tau11
  end interface!tau11
!
  interface tau12
    module procedure dp_tau12
    module procedure mp_tau12
  end interface!tau12
!
  interface my_tiny
    module procedure dp_tiny
    module procedure mp_tiny
  end interface!my_tiny
  contains
!
  function dp_root3(p)
   include 'cts_dpr.h'
    , intent(in) :: p
   include 'cts_dpr.h'
    :: dp_root3,aus
   logical :: computing=.true.
   save aus,computing
   if (computing) then
    computing=.false.
    aus= sqrt(3.d0)
   endif
   dp_root3= aus
  end function dp_root3
!
  function dp_pi(p)
   include 'cts_dpr.h'
    , intent(in) :: p
   include 'cts_dpr.h'
    :: dp_pi,aus
   logical :: computing=.true.
   save aus,computing
   if (computing) then
    computing=.false.
    aus= 4.d0*atan(1.d0)
   endif
   dp_pi= aus
  end function dp_pi
!
  function dp_lambda(p)
   include 'cts_dpr.h'
    , intent(in) :: p
   include 'cts_dpr.h'
    :: dp_lambda,aus
   logical :: computing=.true.
   save aus,computing
   if (computing) then
    computing=.false.
    aus= -1.d0
   endif
   dp_lambda= aus
  end function dp_lambda
!
  function dp_sigma(p)
   include 'cts_dpr.h'
    , intent(in) :: p
   include 'cts_dpr.h'
    :: dp_sigma,aus
   logical :: computing=.true.
   save aus,computing
   if (computing) then
    computing=.false.
    aus= -0.5d0
   endif
   dp_sigma= aus
  end function dp_sigma
!
  function dp_c0(p)
   include 'cts_dpr.h'
    , intent(in) :: p
   include 'cts_dpc.h'
    :: dp_c0,aus
   logical :: computing=.true.
   save aus,computing
   if (computing) then
    computing=.false.
    aus= dcmplx(0.d0,0.d0)
   endif
   dp_c0= aus
  end function dp_c0
!
  function dp_c1(p)
   include 'cts_dpr.h'
    , intent(in) :: p
   include 'cts_dpc.h'
    :: dp_c1,aus
   logical :: computing=.true.
   save aus,computing
   if (computing) then
    computing=.false.
    aus= dcmplx(1.d0,0.d0)
   endif
   dp_c1= aus
  end function dp_c1
!
  function dp_ci(p)
   include 'cts_dpr.h'
    , intent(in) :: p
   include 'cts_dpc.h'
    :: dp_ci,aus
   logical :: computing=.true.
   save aus,computing
   if (computing) then
    computing=.false.
    aus= dcmplx(0.d0,1.d0)
   endif
   dp_ci= aus
  end function dp_ci
!
  function dp_cexp1(p)
   include 'cts_dpr.h'
    , intent(in) :: p
   include 'cts_dpc.h'
    :: dp_cexp1,aus
   logical :: computing=.true.
   save aus,computing
   if (computing) then
    computing=.false.
    aus= exp(ci(p)*pi(p)/1.d0)
   endif
   dp_cexp1= aus
  end function dp_cexp1
!
  function dp_cexp2(p)
   include 'cts_dpr.h'
    , intent(in) :: p
   include 'cts_dpc.h'
    :: dp_cexp2,aus
   logical :: computing=.true.
   save aus,computing
   if (computing) then
    computing=.false.
    aus= exp(ci(p)*pi(p)/2.d0)
   endif
   dp_cexp2= aus
  end function dp_cexp2
!
  function dp_cexp3(p)
   include 'cts_dpr.h'
    , intent(in) :: p
   include 'cts_dpc.h'
    :: dp_cexp3,aus
   logical :: computing=.true.
   save aus,computing
   if (computing) then
    computing=.false.
    aus= exp(ci(p)*pi(p)/3.d0)
   endif
   dp_cexp3= aus
  end function dp_cexp3
!
  function dp_cexp4(p)
   include 'cts_dpr.h'
    , intent(in) :: p
   include 'cts_dpc.h'
    :: dp_cexp4,aus
   logical :: computing=.true.
   save aus,computing
   if (computing) then
    computing=.false.
    aus= exp(ci(p)*pi(p)/4.d0)
   endif
   dp_cexp4= aus
  end function dp_cexp4
!
  function dp_cexpk1(p)
   include 'cts_dpr.h'
    , intent(in) :: p
   include 'cts_dpc.h'
    :: dp_cexpk1,aus
   logical :: computing=.true.
   save aus,computing
   if (computing) then
    computing=.false.
    aus= exp(ci(p)*pi(p)/3.d0)
   endif
   dp_cexpk1= aus
  end function dp_cexpk1
!
  function dp_tau11(p)
   include 'cts_dpr.h'
    , intent(in) :: p
   include 'cts_dpc.h'
    :: dp_tau11,aus
   logical :: computing=.true.
   save aus,computing
   if (computing) then
    computing=.false.
    aus= 1.d0
   endif
   dp_tau11= aus
  end function dp_tau11
!
  function dp_tau12(p)
   include 'cts_dpr.h'
    , intent(in) :: p
   include 'cts_dpc.h'
    :: dp_tau12,aus
   logical :: computing=.true.
   save aus,computing
   if (computing) then
    computing=.false.
    aus= 1.d0
   endif
   dp_tau12= aus
  end function dp_tau12
!
  function dp_tiny(p)
   include 'cts_dpr.h'
    , intent(in) :: p
   include 'cts_dpr.h'
    :: dp_tiny,aus
   logical :: computing=.true.
   save aus,computing
   if (computing) then
    computing=.false.
    aus= tiny(p)
   endif
   dp_tiny= aus
  end function dp_tiny
!
  function mp_root3(p)
   include 'cts_mpr.h'
    , intent(in) :: p
   include 'cts_mpr.h'
    :: mp_root3,aus
   logical :: computing=.true.
   save aus,computing
   if (computing) then
    computing=.false.
    aus= 3.d0
    aus= sqrt(aus)
   endif
   mp_root3= aus
  end function mp_root3
!
  function mp_pi(p)
   include 'cts_mpr.h'
    , intent(in) :: p
   include 'cts_mpr.h'
    :: mp_pi,aus
   logical :: computing=.true.
   save aus,computing
   if (computing) then
    computing=.false.
    aus= 1.d0
    aus= 4.d0*atan(aus)
   endif
   mp_pi= aus
  end function mp_pi
!
  function mp_lambda(p)
   include 'cts_mpr.h'
    , intent(in) :: p
   include 'cts_mpr.h'
    :: mp_lambda,aus
   logical :: computing=.true.
   save aus,computing
   if (computing) then
    computing=.false.
    aus= -1.d0
   endif
   mp_lambda= aus
  end function mp_lambda
!
  function mp_sigma(p)
   include 'cts_mpr.h'
    , intent(in) :: p
   include 'cts_mpr.h'
    :: mp_sigma,aus
   logical :: computing=.true.
   save aus,computing
   if (computing) then
    computing=.false.
    aus= -0.5d0
   endif
   mp_sigma= aus
  end function mp_sigma
!
  function mp_c0(p)
   include 'cts_mpr.h'
    , intent(in) :: p
   include 'cts_mpc.h'
    :: mp_c0,aus
   logical :: computing=.true.
   save aus,computing
   if (computing) then
    computing=.false.
    aus= dcmplx(0.d0,0.d0)
   endif
   mp_c0= aus
  end function mp_c0
!
  function mp_c1(p)
   include 'cts_mpr.h'
    , intent(in) :: p
   include 'cts_mpc.h'
    :: mp_c1,aus
   logical :: computing=.true.
   save aus,computing
   if (computing) then
    computing=.false.
    aus= dcmplx(1.d0,0.d0)
   endif
   mp_c1= aus
  end function mp_c1
!
  function mp_ci(p)
   include 'cts_mpr.h'
    , intent(in) :: p
   include 'cts_mpc.h'
    :: mp_ci,aus
   logical :: computing=.true.
   save aus,computing
   if (computing) then
    computing=.false.
    aus= dcmplx(0.d0,1.d0)
   endif
   mp_ci= aus
  end function mp_ci
!
  function mp_cexp1(p)
   include 'cts_mpr.h'
    , intent(in) :: p
   include 'cts_mpc.h'
    :: mp_cexp1,aus
   logical :: computing=.true.
   save aus,computing
   if (computing) then
    computing=.false.
    aus= exp(ci(p)*pi(p)/1.d0)
   endif
   mp_cexp1= aus
  end function mp_cexp1
!
  function mp_cexp2(p)
   include 'cts_mpr.h'
    , intent(in) :: p
   include 'cts_mpc.h'
    :: mp_cexp2,aus
   logical :: computing=.true.
   save aus,computing
   if (computing) then
    computing=.false.
    aus= exp(ci(p)*pi(p)/2.d0)
   endif
   mp_cexp2= aus
  end function mp_cexp2
!
  function mp_cexp3(p)
   include 'cts_mpr.h'
    , intent(in) :: p
   include 'cts_mpc.h'
    :: mp_cexp3,aus
   logical :: computing=.true.
   save aus,computing
   if (computing) then
    computing=.false.
    aus= exp(ci(p)*pi(p)/3.d0)
   endif
   mp_cexp3= aus
  end function mp_cexp3
!
  function mp_cexp4(p)
   include 'cts_mpr.h'
    , intent(in) :: p
   include 'cts_mpc.h'
    :: mp_cexp4,aus
   logical :: computing=.true.
   save aus,computing
   if (computing) then
    computing=.false.
    aus= exp(ci(p)*pi(p)/4.d0)
   endif
   mp_cexp4= aus
  end function mp_cexp4
!
  function mp_cexpk1(p)
   include 'cts_mpr.h'
    , intent(in) :: p
   include 'cts_mpc.h'
    :: mp_cexpk1,aus
   logical :: computing=.true.
   save aus,computing
   if (computing) then
    computing=.false.
    aus= exp(ci(p)*pi(p)/3.d0)
   endif
   mp_cexpk1= aus
  end function mp_cexpk1
!
  function mp_tau11(p)
   include 'cts_mpr.h'
    , intent(in) :: p
   include 'cts_mpc.h'
    :: mp_tau11,aus
   logical :: computing=.true.
   save aus,computing
   if (computing) then
    computing=.false.
    aus= 1.d0
   endif
   mp_tau11= aus
  end function mp_tau11
!
  function mp_tau12(p)
   include 'cts_mpr.h'
    , intent(in) :: p
   include 'cts_mpc.h'
    :: mp_tau12,aus
   logical :: computing=.true.
   save aus,computing
   if (computing) then
    computing=.false.
    aus= 1.d0
   endif
   mp_tau12= aus
  end function mp_tau12
!
  function mp_tiny(p)
   include 'cts_mpr.h'
    , intent(in) :: p
   include 'cts_mpr.h'
    :: mp_tiny,aus
   logical :: computing=.true.
   save aus,computing
   if (computing) then
    computing=.false.
    aus= tiny(1.d0)
   endif
   mp_tiny= aus
  end function mp_tiny
 end module constants


	SUBROUTINE SNDTRP ( tropht, trpint, delz, nlun, lun, nparms,
     +			    nlevel, hdata, iret )
C************************************************************************
C* SNDTRP								*
C*									*
C* This routine will compute the mean wind and lapse rate above and	*
C* below the tropopause.						*
C*									*
C* SNDTRP ( TROPHT, TRPINT, DELZ, NLUN, LUN, NPARMS, NLEVEL, HDATA,	*
C*	    IRET )							*
C*									*
C* Input parameters:							*
C*	TROPHT		CHAR*		Height of the tropopause	*
C*	TRPINT		CHAR*		Interval above and below trop	*
C*	DELZ		CHAR*		Height interval			*
C*	NLUN		INTEGER		Number of file numbers		*
C*	LUN (NLUN)	INTEGER		File numbers			*
C*	NPARMS		INTEGER		Number of parameters		*
C*	NLEVEL		INTEGER		Number of levels		*
C*	HDATA (LLMXLV)	REAL		Interpolated data		*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal			*
C**									*
C* Log:									*
C* S. Jacobs/SSAI	 4/92						*
C* J. Whistler/SSAI	 4/93		Cleaned up header		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'sndiag.prm'
C*
	CHARACTER*(*)	tropht, trpint, delz
	INTEGER		lun(*)
	REAL		hdata(*)
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Initialize sums.
C
	iret  = 0
	sumbu = 0.
	sumbv = 0.
	sumbd = 0.
	sumbl = 0.
	sumbn = 0.
	sumau = 0.
	sumav = 0.
	sumad = 0.
	sumal = 0.
	suman = 0.
C
C*	Get user input.
C
	CALL ST_CRNM ( tropht, trop, ier )
	IF  ( ier .ne. 0 )  trop = 10000.
	CALL ST_CRNM ( trpint, tropint, ier )
	IF  ( ier .ne. 0 )  tropint = 1000.
	CALL ST_CRNM ( delz, deltaz, ier )
	IF  ( ier .ne. 0 )  deltaz = 500.
C
C*	Loop through the levels.
C
	DO  i = 2, nlevel-1
	    IF  ( .not. ERMISS(hdata((i-1+1)*nparms+ITEMP)) .and.
     +		  .not. ERMISS(hdata((i-1-1)*nparms+ITEMP)) )  THEN
		xlapse = ( hdata((i-1+1)*nparms+ITEMP) -
     +		           hdata((i-1-1)*nparms+ITEMP) ) * 1000. /
     +		         ( 2. * deltaz )
	    ELSE
		xlapse = RMISSD
	    END IF
	    pres = hdata((i-1)*nparms+IPRES)
	    tmpk = PR_TVRK ( hdata((i-1)*nparms+ITEMP),
     +			     hdata((i-1)*nparms+IDWPT),
     +			     hdata((i-1)*nparms+IPRES) )
	    tmpv = PR_TMKC ( tmpk )
	    dens = PR_DDEN ( pres, tmpv )
C
C*	    Find the sums for the appropriate area of the sounding.
C
	    IF  ( hdata((i-1)*nparms+IHGHT) .ge. (trop-tropint) .and.
     +		  hdata((i-1)*nparms+IHGHT) .lt. trop )  THEN
		IF  ( .not. ERMISS(hdata((i-1)*nparms+IUWND)) )  THEN
		    sumbu = sumbu + hdata((i-1)*nparms+IUWND) * dens
		    sumbv = sumbv + hdata((i-1)*nparms+IVWND) * dens
		    sumbd = sumbd + dens
		END IF
		IF  ( .not. ERMISS(xlapse) )  THEN
		    sumbl = sumbl + xlapse * dens
		    sumbn = sumbn + dens
		END IF
	    ELSE IF  ( hdata((i-1)*nparms+IHGHT) .le. (trop+tropint)
     +		 .and. hdata((i-1)*nparms+IHGHT) .gt. trop )  THEN
		IF  ( .not. ERMISS(hdata((i-1)*nparms+IUWND)) )  THEN
		    sumau = sumau + hdata((i-1)*nparms+IUWND) * dens
		    sumav = sumav + hdata((i-1)*nparms+IVWND) * dens
		    sumad = sumad + dens
		END IF
		IF  ( .not. ERMISS(xlapse) )  THEN
		    sumal = sumal + xlapse * dens
		    suman = suman + dens
		END IF
	    END IF
	END DO
C
C*	Compute the mean wind and lapse rate for below and above the
C*	tropopause.
C
	IF  ( sumbd .ne. 0. )  THEN
	    vb = sumbv / sumbd
	    ub = sumbu / sumbd
	    IF  ( ub .eq. 0. .and. vb .eq. 0. )  THEN
		bspd = 0.
		bdir = 0.
	    ELSE
		bspd = PR_SPED ( ub, vb )
		bdir = PR_DRCT ( ub, vb )
	    END IF
	END IF
	IF  ( sumbn .ne. 0. .and. sumbl .ne. 0.)  THEN
	    blps = sumbl / sumbn
	END IF
C
	IF  ( sumad .ne. 0. )  THEN
	    va = sumav / sumad
	    ua = sumau / sumad
	    IF  ( ua .eq. 0. .and. va .eq. 0. )  THEN
		aspd = 0.
		adir = 0.
	    ELSE
		aspd = PR_SPED ( ua, va )
		adir = PR_DRCT ( ua, va )
	    END IF
	END IF
	IF  ( suman .ne. 0. .and. sumal .ne. 0.)  THEN
	    alps = sumal / suman
	END IF
C
C*	Write the output.
C
	DO  k = 1, nlun
	    WRITE ( lun(k), 1000 ) trop, tropint, bspd, bdir, blps,
     +					 tropint, aspd, adir, alps
	END DO
1000	FORMAT ( /, '   TROPOPAUSE MEAN WIND AND LAPSE RATE', /,/,
     +              ' Tropopause Height - Input : ',F10.2,' m',/,
     +              ' Values in layer ',F10.2,' m below tropopause:',/,
     +              '     Mean Wind Speed     : ',F10.2,' m/s',/,
     +              '     Mean Wind Direction : ',F10.2,' degrees',/,
     +              '     Lapse Rate          : ',F10.2,' C/km',/,
     +              ' Values in layer ',F10.2,' m above tropopause:',/,
     +              '     Mean Wind Speed     : ',F10.2,' m/s',/,
     +              '     Mean Wind Direction : ',F10.2,' degrees',/,
     +              '     Lapse Rate          : ',F10.2,' C/km' )
C*
	RETURN
	END


CBSFT
C           BESFIT - LEAST SQUARES CURVE-FITTING ROUTINE
C           USING ORTHOGONAL POLYNOMIALS WITH STATISTICAL
C           TERMINATION
C
C           PROGRAMMER - J.J.MILIA HMED
C
      SUBROUTINE BESFIT(N,X,Y,K,D,RES)
      DIMENSION X(1),Y(1),D( 6),A( 8),B( 8),S( 8),RES( 8),TAB( 6)
      DIMENSION P0(  6),P1(  6),R(6,6)
c     EQUIVALENCE (P0,R),(P1,R(  7))
      EQUIVALENCE (P0,R(1,1)),(P1,R(1,2))
      DATA  TAB           /12.706,4.303,3.182,2.776,2.571,2.447/
      IF(N.GT.1) GO TO 50
      D(1)=Y(1)
      K=0
      GO TO 55
50    KT=0
      IF=K
      IAF=MIN0(IABS(IF),20)
      M=N
      NDEG=M-1
      J=0
      C0=M
      A(1)=0.
      B(1)=0.
      S(1)=0.
      RES(1)=0.
      DO 1 I=1,M
      P0(I)=0.
      P1(I)=1.
      S(1)=S(1)+Y(I)
      A(1)=A(1)+X(I)
1     RES(1)=Y(I)**2+RES(1)
      A(1)=A(1)/C0
      S(1)=S(1)/C0
      RES(1)=RES(1)-S(1)**2*C0
      RMS=RES(1)/(C0-1.)
3     J=J+1
      IF(J.GT. IAF.AND.IF.NE.0 ) GO TO 27
      IF(J.LE.22) GO TO 24
27    K=IAF
      LL=K+1
C     WRITE(16,29) IAF
      GO TO 4
24    C1=0.
      XPP=0.
      YP=0.
      DO 2 I=1,M
      Q=P1(I)
      P1(I)=(X(I)-A(J))*Q-B(J)*P0(I)
      P0(I)=Q
      PP=P1(I)**2
      C1=PP+C1
      XPP=XPP+X(I)*PP
2     YP=YP+Y(I)*P1(I)
      S(J+1)=YP/C1
      SSR=S(J+1)**2*C1
      RES(J+1)=RES(J)-SSR
      IF(RES(J+1).GT.0.) GO TO 13
      K=J
      IF(RES(J).LT.ABS(RES(J+1))) K=J-1
      LL=K+1
C     WRITE(16,14) K
      CONTINUE
      GO TO 4
13    A(J+1)=XPP/C1
      B(J+1)=C1/C0
      C0=C1
      LL=J+1
C     IF(IF.GT.0) IF(LL-IF) 3,3,4
C     replaced by ..........
      IF(IF.GT.0) THEN
         IF(( LL-IF).LE.0) THEN
             GO TO 3
         ELSE
             GO TO 4
         ENDIF
      ENDIF
      NDEG=NDEG-1
      RMS=RES(J+1)/FLOAT(NDEG)
C     ISUB=MIN0(NDEG,20)
      ISUB=MIN0(NDEG, 6)
      T=SQRT(SSR/RMS)
C array index error here - 11/25/03 RWC
	if (ISUB.LT.1) ISUB=1

      IF(T.LE.TAB(ISUB)) GO TO 17
      KT=0
      GO TO 3
17    S(J+1)=0.
      RES(J+1)=RES(J)
      NDEG=NDEG+1
      IF(KT.EQ.1) GO TO 18
      KT=1
      GO TO 3
18    LL=J-1
      K=J-2
4     R(1,1)=1.
      R(1,2)=-A(1)
      R(2,2)=1.
      R(2,1)=0.
C     IF(K-2) 6,8,8
C     replaced by..........
      IF(K.LT.2) THEN
        GO TO 6
      ELSE
        GO TO 8
      ENDIF
8     DO 9 I=3,LL
      R(1,I)=-A(I-1)*R(1,I-1)-B(I-1)*R(1,I-2)
      LOOP=I-2
      R(I-1,I)=R(I-2,I-1)-A(I-1)*R(I-1,I-1)
      R(I,I)=1.
      DO 9 JJ=2,LOOP
      R(JJ,I)=R(JJ-1,I-1)-A(I-1)*R(JJ,I-1)-B(I-1)*R(JJ,I-2)
9     CONTINUE
6     DO 10 JJ=1,LL
      D(JJ)=0.
      DO 10 L=JJ,LL
10    D(JJ)=D(JJ)+S(L)*R(JJ,L)
55    RETURN
14    FORMAT(28H0BESFIT RETURNED WITH ORDER ,I2//)
29    FORMAT(18H0BESFIT LIMITED TO,I3,9HTH ORDER.//)
      END


*     TB04BD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX, MDMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20,
     $                   MDMAX = NMAX + 1 )
      INTEGER          PMNMAX
      PARAMETER        ( PMNMAX = PMAX*MMAX*MDMAX )
      INTEGER          LDA, LDB, LDC, LDD, LDIGD, LDIGN
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDD = PMAX, LDIGD = PMAX, LDIGN = PMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX*( NMAX + PMAX ) +
     $                            MAX( NMAX + MAX( NMAX, PMAX ),
     $                                 NMAX*( 2*NMAX + 5 ) ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, IJ, INFO, J, K, M, MD, N, P
      CHARACTER*1      JOBD, ORDER, EQUIL
      CHARACTER*132    ULINE
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 D(LDD,MMAX), DWORK(LDWORK), GD(PMNMAX),
     $                 GN(PMNMAX)
      INTEGER          IGD(LDIGD,MMAX), IGN(LDIGN,MMAX), IWORK(LIWORK)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         TB04BD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, TOL, JOBD, ORDER, EQUIL
      MD = N + 1
      ULINE(1:20) = ' '
      DO 20 I = 21, 132
         ULINE(I:I) = '-'
   20 CONTINUE
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99991 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99990 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99989 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P )
*              Find the transfer matrix T(s) of (A,B,C,D).
               CALL TB04BD( JOBD, ORDER, EQUIL, N, M, P, MD, A, LDA, B,
     $                      LDB, C, LDC, D, LDD, IGN, LDIGN, IGD, LDIGD,
     $                      GN, GD, TOL, IWORK, DWORK, LDWORK, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  IF ( LSAME( ORDER, 'I' ) ) THEN
                     WRITE ( NOUT, FMT = 99997 )
                  ELSE
                     WRITE ( NOUT, FMT = 99996 )
                  END IF
                  WRITE ( NOUT, FMT = 99995 )
                  DO 60 J = 1, M
                     DO 40 I = 1, P
                        IJ = ( (J-1)*P + I-1 )*MD + 1
                        WRITE ( NOUT, FMT = 99994 ) I, J,
     $                    ( GN(K), K = IJ,IJ+IGN(I,J) )
                        WRITE ( NOUT, FMT = 99993 )
     $                          ULINE(1:7*(IGD(I,J)+1)+21)
                        WRITE ( NOUT, FMT = 99992 )
     $                        ( GD(K), K = IJ,IJ+IGD(I,J) )
   40                CONTINUE
   60             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TB04BD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TB04BD = ',I2)
99997 FORMAT (/' The polynomial coefficients appear in increasing',
     $         ' order'/' of the powers of the indeterminate')
99996 FORMAT (/' The polynomial coefficients appear in decreasing',
     $         ' order'/' of the powers of the indeterminate')
99995 FORMAT (/' The coefficients of polynomials in the transfer matri',
     $       'x T(s) are ')
99994 FORMAT (/' element (',I2,',',I2,') is ',20(1X,F6.2))
99993 FORMAT (1X,A)
99992 FORMAT (20X,20(1X,F6.2))
99991 FORMAT (/' N is out of range.',/' N = ',I5)
99990 FORMAT (/' M is out of range.',/' M = ',I5)
99989 FORMAT (/' P is out of range.',/' P = ',I5)
      END


*DECK ZBESY
      SUBROUTINE ZBESY (ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, CWRKR,
     +   CWRKI, IERR)
C***BEGIN PROLOGUE  ZBESY
C***PURPOSE  Compute a sequence of the Bessel functions Y(a,z) for
C            complex argument z and real nonnegative orders a=b,b+1,
C            b+2,... where b>0.  A scaling option is available to
C            help avoid overflow.
C***LIBRARY   SLATEC
C***CATEGORY  C10A4
C***TYPE      COMPLEX (CBESY-C, ZBESY-C)
C***KEYWORDS  BESSEL FUNCTIONS OF COMPLEX ARGUMENT,
C             BESSEL FUNCTIONS OF SECOND KIND, WEBER'S FUNCTION,
C             Y BESSEL FUNCTIONS
C***AUTHOR  Amos, D. E., (SNL)
C***DESCRIPTION
C
C                      ***A DOUBLE PRECISION ROUTINE***
C         On KODE=1, ZBESY computes an N member sequence of complex
C         Bessel functions CY(L)=Y(FNU+L-1,Z) for real nonnegative
C         orders FNU+L-1, L=1,...,N and complex Z in the cut plane
C         -pi<arg(Z)<=pi where Z=ZR+i*ZI.  On KODE=2, CBESY returns
C         the scaled functions
C
C            CY(L) = exp(-abs(Y))*Y(FNU+L-1,Z),  L=1,...,N, Y=Im(Z)
C
C         which remove the exponential growth in both the upper and
C         lower half planes as Z goes to infinity.  Definitions and
C         notation are found in the NBS Handbook of Mathematical
C         Functions (Ref. 1).
C
C         Input
C           ZR     - DOUBLE PRECISION real part of nonzero argument Z
C           ZI     - DOUBLE PRECISION imag part of nonzero argument Z
C           FNU    - DOUBLE PRECISION initial order, FNU>=0
C           KODE   - A parameter to indicate the scaling option
C                    KODE=1  returns
C                            CY(L)=Y(FNU+L-1,Z), L=1,...,N
C                        =2  returns
C                            CY(L)=Y(FNU+L-1,Z)*exp(-abs(Y)), L=1,...,N
C                            where Y=Im(Z)
C           N      - Number of terms in the sequence, N>=1
C           CWRKR  - DOUBLE PRECISION work vector of dimension N
C           CWRKI  - DOUBLE PRECISION work vector of dimension N
C
C         Output
C           CYR    - DOUBLE PRECISION real part of result vector
C           CYI    - DOUBLE PRECISION imag part of result vector
C           NZ     - Number of underflows set to zero
C                    NZ=0    Normal return
C                    NZ>0    CY(L)=0 for NZ values of L, usually on
C                            KODE=2 (the underflows may not be in an
C                            uninterrupted sequence)
C           IERR   - Error flag
C                    IERR=0  Normal return     - COMPUTATION COMPLETED
C                    IERR=1  Input error       - NO COMPUTATION
C                    IERR=2  Overflow          - NO COMPUTATION
C                            (abs(Z) too small and/or FNU+N-1
C                            too large)
C                    IERR=3  Precision warning - COMPUTATION COMPLETED
C                            (Result has half precision or less
C                            because abs(Z) or FNU+N-1 is large)
C                    IERR=4  Precision error   - NO COMPUTATION
C                            (Result has no precision because
C                            abs(Z) or FNU+N-1 is too large)
C                    IERR=5  Algorithmic error - NO COMPUTATION
C                            (Termination condition not met)
C
C *Long Description:
C
C         The computation is carried out by the formula
C
C            Y(a,z) = (H(1,a,z) - H(2,a,z))/(2*i)
C
C         where the Hankel functions are computed as described in CBESH.
C
C         For negative orders, the formula
C
C            Y(-a,z) = Y(a,z)*cos(a*pi) + J(a,z)*sin(a*pi)
C
C         can be used.  However, for large orders close to half odd
C         integers the function changes radically.  When a is a large
C         positive half odd integer, the magnitude of Y(-a,z)=J(a,z)*
C         sin(a*pi) is a large negative power of ten.  But when a is
C         not a half odd integer, Y(a,z) dominates in magnitude with a
C         large positive power of ten and the most that the second term
C         can be reduced is by unit roundoff from the coefficient.
C         Thus,  wide changes can occur within unit roundoff of a large
C         half odd integer.  Here, large means a>abs(z).
C
C         In most complex variable computation, one must evaluate ele-
C         mentary functions.  When the magnitude of Z or FNU+N-1 is
C         large, losses of significance by argument reduction occur.
C         Consequently, if either one exceeds U1=SQRT(0.5/UR), then
C         losses exceeding half precision are likely and an error flag
C         IERR=3 is triggered where UR=MAX(D1MACH(4),1.0D-18) is double
C         precision unit roundoff limited to 18 digits precision.  Also,
C         if either is larger than U2=0.5/UR, then all significance is
C         lost and IERR=4.  In order to use the INT function, arguments
C         must be further restricted not to exceed the largest machine
C         integer, U3=I1MACH(9).  Thus, the magnitude of Z and FNU+N-1
C         is restricted by MIN(U2,U3).  In IEEE arithmetic, U1,U2, and
C         U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision
C         and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision.  This
C         makes U2 limiting in single precision and U3 limiting in
C         double precision.  This means that one can expect to retain,
C         in the worst cases on IEEE machines, no digits in single pre-
C         cision and only 6 digits in double precision.  Similar con-
C         siderations hold for other machines.
C
C         The approximate relative error in the magnitude of a complex
C         Bessel function can be expressed as P*10**S where P=MAX(UNIT
C         ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre-
C         sents the increase in error due to argument reduction in the
C         elementary functions.  Here, S=MAX(1,ABS(LOG10(ABS(Z))),
C         ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF
C         ABS(Z),ABS(EXPONENT OF FNU)) ).  However, the phase angle may
C         have only absolute accuracy.  This is most likely to occur
C         when one component (in magnitude) is larger than the other by
C         several orders of magnitude.  If one component is 10**K larger
C         than the other, then one can expect only MAX(ABS(LOG10(P))-K,
C         0) significant digits; or, stated another way, when K exceeds
C         the exponent of P, no significant digits remain in the smaller
C         component.  However, the phase angle retains absolute accuracy
C         because, in complex arithmetic with precision P, the smaller
C         component will not (as a rule) decrease below P times the
C         magnitude of the larger component.  In these extreme cases,
C         the principal phase angle is on the order of +P, -P, PI/2-P,
C         or -PI/2+P.
C
C***REFERENCES  1. M. Abramowitz and I. A. Stegun, Handbook of Mathe-
C                 matical Functions, National Bureau of Standards
C                 Applied Mathematics Series 55, U. S. Department
C                 of Commerce, Tenth Printing (1972) or later.
C               2. D. E. Amos, Computation of Bessel Functions of
C                 Complex Argument, Report SAND83-0086, Sandia National
C                 Laboratories, Albuquerque, NM, May 1983.
C               3. D. E. Amos, Computation of Bessel Functions of
C                 Complex Argument and Large Order, Report SAND83-0643,
C                 Sandia National Laboratories, Albuquerque, NM, May
C                 1983.
C               4. D. E. Amos, A Subroutine Package for Bessel Functions
C                 of a Complex Argument and Nonnegative Order, Report
C                 SAND85-1018, Sandia National Laboratory, Albuquerque,
C                 NM, May 1985.
C               5. D. E. Amos, A portable package for Bessel functions
C                 of a complex argument and nonnegative order, ACM
C                 Transactions on Mathematical Software, 12 (September
C                 1986), pp. 265-273.
C
C***ROUTINES CALLED  D1MACH, I1MACH, ZBESH
C***REVISION HISTORY  (YYMMDD)
C   830501  DATE WRITTEN
C   890801  REVISION DATE from Version 3.2
C   910415  Prologue converted to Version 4.0 format.  (BAB)
C   920128  Category corrected.  (WRB)
C   920811  Prologue revised.  (DWL)
C***END PROLOGUE  ZBESY
C
C     COMPLEX CWRK,CY,C1,C2,EX,HCI,Z,ZU,ZV
      DOUBLE PRECISION CWRKI, CWRKR, CYI, CYR, C1I, C1R, C2I, C2R,
     * ELIM, EXI, EXR, EY, FNU, HCII, STI, STR, TAY, ZI, ZR,
     * D1MACH, ASCLE, RTOL, ATOL, AA, BB, TOL, R1M5
      INTEGER I, IERR, K, KODE, K1, K2, N, NZ, NZ1, NZ2, I1MACH
      DIMENSION CYR(N), CYI(N), CWRKR(N), CWRKI(N)
C***FIRST EXECUTABLE STATEMENT  ZBESY
      IERR = 0
      NZ=0
      IF (ZR.EQ.0.0D0 .AND. ZI.EQ.0.0D0) IERR=1
      IF (FNU.LT.0.0D0) IERR=1
      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
      IF (N.LT.1) IERR=1
      IF (IERR.NE.0) RETURN
      HCII = 0.5D0
      CALL ZBESH(ZR, ZI, FNU, KODE, 1, N, CYR, CYI, NZ1, IERR)
      IF (IERR.NE.0.AND.IERR.NE.3) GO TO 170
      CALL ZBESH(ZR, ZI, FNU, KODE, 2, N, CWRKR, CWRKI, NZ2, IERR)
      IF (IERR.NE.0.AND.IERR.NE.3) GO TO 170
      NZ = MIN(NZ1,NZ2)
      IF (KODE.EQ.2) GO TO 60
      DO 50 I=1,N
        STR = CWRKR(I) - CYR(I)
        STI = CWRKI(I) - CYI(I)
        CYR(I) = -STI*HCII
        CYI(I) = STR*HCII
   50 CONTINUE
      RETURN
   60 CONTINUE
      TOL = MAX(D1MACH(4),1.0D-18)
      K1 = I1MACH(15)
      K2 = I1MACH(16)
      K = MIN(ABS(K1),ABS(K2))
      R1M5 = D1MACH(5)
C-----------------------------------------------------------------------
C     ELIM IS THE APPROXIMATE EXPONENTIAL UNDER- AND OVERFLOW LIMIT
C-----------------------------------------------------------------------
      ELIM = 2.303D0*(K*R1M5-3.0D0)
      EXR = COS(ZR)
      EXI = SIN(ZR)
      EY = 0.0D0
      TAY = ABS(ZI+ZI)
      IF (TAY.LT.ELIM) EY = EXP(-TAY)
      IF (ZI.LT.0.0D0) GO TO 90
      C1R = EXR*EY
      C1I = EXI*EY
      C2R = EXR
      C2I = -EXI
   70 CONTINUE
      NZ = 0
      RTOL = 1.0D0/TOL
      ASCLE = D1MACH(1)*RTOL*1.0D+3
      DO 80 I=1,N
C       STR = C1R*CYR(I) - C1I*CYI(I)
C       STI = C1R*CYI(I) + C1I*CYR(I)
C       STR = -STR + C2R*CWRKR(I) - C2I*CWRKI(I)
C       STI = -STI + C2R*CWRKI(I) + C2I*CWRKR(I)
C       CYR(I) = -STI*HCII
C       CYI(I) = STR*HCII
        AA = CWRKR(I)
        BB = CWRKI(I)
        ATOL = 1.0D0
        IF (MAX(ABS(AA),ABS(BB)).GT.ASCLE) GO TO 75
          AA = AA*RTOL
          BB = BB*RTOL
          ATOL = TOL
   75   CONTINUE
        STR = (AA*C2R - BB*C2I)*ATOL
        STI = (AA*C2I + BB*C2R)*ATOL
        AA = CYR(I)
        BB = CYI(I)
        ATOL = 1.0D0
        IF (MAX(ABS(AA),ABS(BB)).GT.ASCLE) GO TO 85
          AA = AA*RTOL
          BB = BB*RTOL
          ATOL = TOL
   85   CONTINUE
        STR = STR - (AA*C1R - BB*C1I)*ATOL
        STI = STI - (AA*C1I + BB*C1R)*ATOL
        CYR(I) = -STI*HCII
        CYI(I) =  STR*HCII
        IF (STR.EQ.0.0D0 .AND. STI.EQ.0.0D0 .AND. EY.EQ.0.0D0) NZ = NZ
     *   + 1
   80 CONTINUE
      RETURN
   90 CONTINUE
      C1R = EXR
      C1I = EXI
      C2R = EXR*EY
      C2I = -EXI*EY
      GO TO 70
  170 CONTINUE
      NZ = 0
      RETURN
      END


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -*- Mode: F89 -*- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! fb250.f90 Fabre, Suzanne test case No. 250
!! Auteur: Aditya Karnik (Imperial) <a.karnik06@imperial.ac.uk>
!! Cree le         : Wed Apr 26  14:21:00 2017
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
module USER
  use BLUE

  implicit none

  real(kind=d), parameter :: ex_force_phase1 = 6.7_d    ! (Pa/m = Newton/m^3)
  real(kind=d), parameter :: ex_force_phase2 = 6.7_d    ! (Pa/m = Newton/m^3)
  real(kind=d), parameter :: INT_height      = 0.0315_d  ! (m)

  public :: USER_int, USER_force

  contains

!***********************************************************************
  subroutine USER_int(ini)
!***********************************************************************
    implicit none

    type(ini_3d), intent(inout) :: ini
    real(kind=d) :: ox, oy, oz

    ox=0.50_d*(BOX(1)+BOX(2))
    oy=0.50_d*(BOX(3)+BOX(4))
    oz=INT_height

    call INE_plane(INI=ini, BASEPOINT=[ox,oy,oz], ORIENTATION=[0.0_d,0.0_d,1.0_d])

    call INE_finalize(INI=ini)
    end subroutine USER_int
!***********************************************************************
  subroutine USER_force(com, msh, var)
!***********************************************************************
    implicit none

    class(com_3d), intent(in)   :: com
    type(msh_3d), intent(in)    :: msh
    type(var_3d), intent(inout) :: var

    real(kind=d) :: acceleration_phase1, acceleration_phase2, func

!    func = 0.5 - atan(8.75*(2.5-BLUE_TIME))/BLUE_PI_VALUE;
    func = 1.;

!    print *,func

    acceleration_phase1 = (func*ex_force_phase1) / density_phase_1
    acceleration_phase2 = (func*ex_force_phase2) / density_phase_2

    var%u%fe(:,:,:) = acceleration_phase1 + (acceleration_phase2 - acceleration_phase1)*var%h%ohv(:,:,:)

  end subroutine USER_force
  !***********************************************************************

  !***********************************************************************
  subroutine USER_init(com, msh, var)
!***********************************************************************
    implicit none

    class(com_3d), intent(in)    :: com
    type(msh_3d),  intent(in)    :: msh
    type(var_3d),  intent(inout) :: var

!    ! Locals
    integer :: i, j, k, npts,isw,isw1,isw2,ipts,nypts
    real(kind=d), parameter :: ustarG = 0.33_d
    real(kind=d), parameter :: ustarI = 0.47_d
    real(kind=d), parameter :: ustarL = 0.0285_d
    real(kind=d), parameter :: nug = 1.56e-5_d
    real(kind=d), parameter :: nul = 8.91e-7_d
    real(kind=d) :: h,dz,zloc,yp,hi,vtemp,kc,yh,Ufit,len,ystarG,ystarI,ystarL,umag
    real(kind=d) :: fluxg,fluxl,yloc,w,kj,dy,rmag

    ystarG = nug/ustarG
    ystarI = nug/ustarI
    ystarL = nul/ustarL

    var%u%fn(:,:,:)=0.0_d
    var%w%fn(:,:,:)=0.0_d
    var%v%fn(:,:,:)=0.0_d

    len = BOX(2)-BOX(1)
    h = BOX(6)-BOX(5)
    w = BOX(4)-BOX(3)

    npts = msh%p%kend - 2
    dz = h/npts

    nypts = msh%p%jend - 2
    dy = w/nypts

    hi = INT_height

    isw = 0
    isw1 = 0
    isw2 = 0

    ipts = 0

    fluxg = 0
    fluxl = 0

    do k=msh%u%mem_kend-1,msh%u%mem_kstart+1,-1
       zloc = h - msh%p%z(k)

       if(zloc > 0) then
       if (zloc < (h-hi) ) then

          yp = (h-hi)/2
          if (zloc < yp) then
             ipts = ipts+1
             umag = max( (((log(zloc/ystarG) / 0.4) + 5.5) * ustarG), 0.0_d)

             kj = (umag/ustarG) - (log((w/2.0_d)/ystarG) / 0.4)
             do j=msh%u%mem_jstart+1,msh%u%mem_jend-1
                yloc = msh%p%y(j)
                if(yloc>0)then
                   if(yloc<=(w/2.0_d))then
                      rmag = ((log(yloc/ystarG) / 0.4) + kj) * ustarG;
                      var%u%fn(:,j,k) = rmag
                      fluxg = fluxg + (dz*dy*rmag)
                   else
                      if(yloc<w)then
                         rmag = ((log((w-yloc)/ystarG) / 0.4) + kj) * ustarG;
                         var%u%fn(:,j,k) = rmag
                         fluxg = fluxg + (dz*dy*rmag)
                      end if
                   end if
                end if
             end do
          else
             isw=isw+1
             if(isw==1) then
                vtemp = ((log((zloc-dz)/ystarG) / 0.4) + 5.5) * ustarG
                kc = (vtemp/ustarI) - (log((h-hi-zloc)/ystarI) / 0.4)
             end if
             ipts = ipts+1
             umag = max( (((log((h-hi-zloc)/ystarI) / 0.4) + kc) * ustarI), 0.0_d)
             kj = (umag/ustarG) - (log((w/2.0_d)/ystarG) / 0.4)
             do j=msh%u%mem_jstart+1,msh%u%mem_jend-1
                yloc = msh%p%y(j)
                if(yloc>0)then
                   if(yloc<=(w/2.0_d))then
                      rmag = ((log(yloc/ystarG) / 0.4) + kj) * ustarG;
                      var%u%fn(:,j,k) = rmag
                      fluxg = fluxg + (dz*dy*rmag)
                   else
                      if(yloc<w)then
                         rmag = ((log((w-yloc)/ystarG) / 0.4) + kj) * ustarG;
                         var%u%fn(:,j,k) = rmag
                         fluxg = fluxg + (dz*dy*rmag)
                      end if
                   end if
                end if
             end do
          end if
       else
          yp = 0.6*hi
          if( zloc < (h-yp) ) then
             yh = (h-zloc)/hi
             isw1=isw1+1
             if (isw1 == 1) then
                vtemp = ((log((h-hi-(zloc-dz))/ystarI) / 0.4) + kc) * ustarI
                Ufit = vtemp / (yh-(0.39*(sin(BLUE_PI_VALUE*(1-yh)))))
             end if
             ipts = ipts+1
             umag = max( (Ufit * (yh-(0.39*(sin(BLUE_PI_VALUE*(1-yh)))))), 0.0_d)
             kj = (umag/ustarL) - (log((w/2.0_d)/ystarL) / 0.4)
             do j=msh%u%mem_jstart+1,msh%u%mem_jend-1
                yloc = msh%p%y(j)
                if(yloc>0)then
                   if(yloc<=(w/2.0_d))then
                      rmag = ((log(yloc/ystarL) / 0.4) + kj) * ustarL;
                      var%u%fn(:,j,k) = rmag
                      fluxl = fluxl + (dz*dy*rmag)
                   else
                      if(yloc<w)then
                         rmag = ((log((w-yloc)/ystarL) / 0.4) + kj) * ustarL;
                         var%u%fn(:,j,k) = rmag
                         fluxl = fluxl + (dz*dy*rmag)
                      end if
                   end if
                end if
             end do
          else
             isw2=isw2+1
            if (isw2 == 1) then
                yh = (h-(zloc-dz))/hi
                vtemp = Ufit * (yh-(0.39*(sin(BLUE_PI_VALUE*(1-yh)))))
                kc = (vtemp/ustarL) - (log((h-zloc)/ystarL) / 0.4)
             end if
             if(zloc < h) then
                 ipts = ipts+1
                 umag = max( (((log((h-zloc)/ystarL) / 0.4) + kc) * ustarL), 0.0_d)
                 kj = (umag/ustarL) - (log((w/2.0_d)/ystarL) / 0.4)
             do j=msh%u%mem_jstart+1,msh%u%mem_jend-1
                yloc = msh%p%y(j)
                if(yloc>0)then
                   if(yloc<=(w/2.0_d))then
                      rmag = ((log(yloc/ystarL) / 0.4) + kj) * ustarL;
                      var%u%fn(:,j,k) = rmag
                      fluxl = fluxl + (dz*dy*rmag)
                   else
                      if(yloc<w)then
                         rmag = ((log((w-yloc)/ystarL) / 0.4) + kj) * ustarL;
                         var%u%fn(:,j,k) = rmag
                         fluxl = fluxl + (dz*dy*rmag)
                      end if
                   end if
                end if
             end do
                end if
          end if
       end if
       end if
    end do

!print *,"FLUX ",fluxg,fluxl
!!$ do i=msh%u%mem_istart+1,msh%u%mem_iend-1
!!$    do j=msh%u%mem_jstart+1,msh%u%mem_jend-1
!!$       do k=msh%u%mem_kend-1,msh%u%mem_kstart+1,-1
!!$
!!$          zloc = msh%p%z(k)
!!$
!!$          if (zloc < INT_height) then
!!$             var%u%fn(i,j,k) = 0.4
!!$          else
!!$             var%u%fn(i,j,k) = 4.5
!!$          end if
!!$
!!$       end do
!!$    end do
!!$ end do

    var%w%fn(:,:,:)=0.0_d
    var%v%fn(:,:,:)=0.0_d

  end subroutine USER_init
  !***********************************************************************

  !***********************************************************************
  subroutine USER_les(msh, var)
!***********************************************************************
    implicit none

    type(msh_3d), intent(in)    :: msh
    type(var_3d), intent(inout) :: var

    integer :: k
    real(kind=d) :: zloc

    do k=msh%p%kend-1,msh%p%kstart+1,-1
       zloc = msh%p%z(k)
          if (zloc < INT_height) then
             var%p%mu(:,:,k) = 0.04045_d
          else
             var%p%mu(:,:,k) = 1.85e-5_d
          end if
    end do

  end subroutine USER_les

end module USER

program qinghua
  use USER

  implicit none

  type(com_3d)        :: com
  type(msh_3d)        :: msh
  type(eno_3d)        :: adv
  type(var_3d)        :: var
!  type(exp_mgmres_3d) :: solver
  type(gmres_mgmres_3d) :: solver
  type(BLUE_CLOCK)    :: clock
  integer             :: fd
  integer             :: time_step_index, code

  ! Set MSH.
  call MSH_set(COM=com, MSH=msh)

  ! Set VAR.
  call VAR_set(COM=com, MSH=msh, VAR=var, INITIAL_METHOD=USER_init, FORCE_METHOD=USER_force, INITIAL_INTERFACE=USER_int,LES_METHOD=USER_les)

  ! Set. ADV.
  call ADV_set(COM=com, MSH=msh, ADV=adv)

  ! Set solvers & operators
  call SOL_set(COM=com, MSH=msh, VAR=var, SOL=solver)

  ! Read restart file
  call RST_read(COM=com, MSH=msh, ADV=adv, VAR=var, FD=fd)

  ! Start time counter
  call clock%start(LABEL="QINGHUA")

  TIMESTEP: do time_step_index = 1, NUM_TIME_STEP

    ! Solve interface/momentum equations.
    call BLUE_solve(COM=com, MSH=msh, ADV=adv, SOL=solver, VAR=var)

    ! Output some infos on the screen.
    call IOF_output(COM=com, MSH=msh, VAR=var, SOL=solver)

    ! Write restart file.
    call RST_write(COM=com, MSH=msh, ADV=adv, VAR=var, FD=fd)

    ! Exit from time loop if run time is reached
    if ( BLUE_MUST_QUIT ) exit TIMESTEP

  end do TIMESTEP

  ! Stop time counter
  call clock%stop(LABEL="QINGHUA")

  ! Finalize
  call COM%free()
end program qinghua


C NMR: NMR_FIT2T1
C ----
C
C Fit two saturatikjon recovery T1 curves to a dataset
C
C Input:
C   - file for fitting
C Notes:
C   The fitting assumes a function of the form:
C
C      A(1-exp(-t/tr1)) + B(1-exp(-t/tr2))
C
C For all fits the NAG routine E04FDF is used for the least squares
C minimization.
C
C
       implicit   NONE
C
C Data file definitions
       integer    max_size
       parameter (max_size = 1024)
       integer    npts
C Estimates for results and limits on the data
       real*4     scale, step, xx
C array for fitted data spectrum
       real*4     xfit(max_size), yfit(max_size), x_max, x_min,
     *            y_max, y_min
C data arrays passed in common
       real*4     x(max_size), y(max_size)
       common    /fitdat/ x, y, scale
C
C Output unit
       integer    iout
       parameter (iout = 6)
C
C Local variables used in NAG fit
       integer    len_work
       parameter (len_work = 400 + 16*max_size)
       real*8     fsumsq, fit(4), work(len_work)
       integer    nvals, ndata, iwork(100), ifail
C loop counter
       integer    n
C file and directory name
       character*256  dir, file
C unit and spectrum identifiers
       integer        iunit, id
C status
       integer        status

C standard include files
       include '/mrao/include/chrlib_functions.inc'
       include '../include/spec_global.inc'
       include '../include/spec_pars.inc'

C initialise
       call io_initio
       call cmd_extpars( 'SPECTRUM', dir, status )
       call cmd_getiline( 'nmr_fit2T1',
     *      dir(1:chr_lenb(dir))//anal_definitions, status)

C find input file name and allocate file
       call cmd_items( 'file', file, status)
       call spec_allocate( file(1:chr_lenb(file)),
     *                     'read', id, status)

C read data
       call spec_get_data( id, 1, x, npts, status)
       call spec_get_data( id, 2, y, npts, status)
       x_max = -1.0E+30
       x_min = 1.0E+30
       y_max = -1.0E+30
       y_min = 1.0E+30
       do n = 1,npts
         x_max = max(x_max,x(n))
         x_min = min(x_min,x(n))
         y_max = max(y_max,y(n))
         y_min = min(y_min,y(n))
       enddo

C deallocate
       call spec_deallocate( id, status )

C sort out options
       scale = 1.0/y_max
       fit(1) = 1.0
       fit(2) = x_max/float(npts)
       fit(3) = 0.0
       fit(4) = x_max/float(npts)
       ndata = npts

C fit a relaxation curve to the data
       ifail = 1
       nvals = 2
C .. find initial guesses
       call e04fdf(ndata, nvals, fit, fsumsq,
     *             iwork, 100, work, len_work, ifail)
       nvals = 4
       fit(3) = fit(1)/10.0
       fit(4) = fit(2)
       ifail = 1
       print *,'STARING-GUESS: ',fit
       call e04fdf(ndata, nvals, fit, fsumsq,
     *             iwork, 100, work, len_work, ifail)
       if (ifail.ne.0) then
         print *,'***(FIT2T1) Ifail non-zero from NAG = ',ifail
         if (ifail.eq.1) goto 999
       end if
       write( iout, 110 ) ndata, fsumsq,
     *      fit(1)/scale,fit(2),fit(3)/scale,fit(4)
110      format(1X/
     *          1X,'.. Results of fitting  A(1-exp(-t/tr1)) + '/
     *          1X,'                          B(1-exp(-t/tr1))'/
     *          1X,'.. Number data points = ',I12,
     *          1X,'   Sum of squares     = ',1PE12.3/
     *          1X,'..                A   = ',1PE12.3,
     *          1X,'                  tr1 = ',1PE12.3/
     *          1X,'..                B   = ',1PE12.3,
     *          1X,'                  tr2 = ',1PE12.3)

C construct output spectrum as a fit to these data
       step = (1.1*x_max-x_min*0.9)/float(10*ndata-1)
       call cmd_items('fit',file,status)
       call io_opefil( iunit, file(1:chr_lenb(file)), 'WRITE', 0,
     *                 status )
       write(iunit,*)'%ncols 2 '
       write(iunit,*)'%ndata ',10*ndata
         do n=1,10*ndata
           xx = x_min*0.9 + float(n-1)*step
           xfit(n) = xx
           yfit(n) = fit(1)*(1.0-exp(-xx/fit(2))) +
     *               fit(3)*(1.0-exp(-xx/fit(4)))
           yfit(n) = yfit(n)/scale
           write(iunit,*) xfit(n), yfit(n)
         end do
       close (iunit)

999    continue

       end
C
C
       subroutine LSFUN1( ndata, nvals, fit, f )
C
C Routine required by NAG -- see definition in NAG manual for details
C
       integer    nvals, ndata
       real*8     fit(nvals), f(ndata)

C Data passed in common
       integer    max_size
       parameter (max_size = 1024)
       real*4     x(max_size), y(max_size), scale
       common    /fitdat/ x, y, scale

       integer    n
       if (nvals.eq.2) then
         do n=1,ndata
             f(n) = y(n)*scale -
     *                fit(1)*(1.0-exp(-x(n)/fit(2)))
         end do
       else
         do n=1,ndata
             f(n) = y(n)*scale -
     *                fit(1)*(1.0-exp(-x(n)/fit(2))) -
     *                fit(3)*(1.0-exp(-x(n)/fit(4)))
         end do
       endif
       end


program optim_test
  use m_gp_optim
  use m_gp_example

  implicit none

  integer, parameter :: Nout = 1000
  integer :: i
  real(dp) :: a

  call gp_example_initialise

  call log_lik_optim(ntheta = 3, gp = gpDense, &
       lbounds = [1e-10_dp, 0.1_dp, 0.1_dp], &
       ubounds = [10.0_dp, 100.0_dp, 5.0_dp], &
       iterations = 100, ftol_rel = 0.0001_dp)

  do i=1,N
     write (8,*) x(i,1), t(i)
  end do

  do i=0,Nout
     a = 5.0_dp*i/Nout
     write (7,*) a, gpDense%predict([a], 0)
  end do

end program optim_test


       subroutine m2derivs(x,y,yprime)
       common /myvar/ a,b,c,e,taur,twomu,xmhigh1,xmhigh2
       common /myvar1/ gdotr(2),tau(2)
       dimension y(2),yprime(2)
       sat=1.0/1.00
       ratio1=((abs(y(1)/taur)*sat)**(xmhigh1-1.))*(y(1)/taur)*sat
       ratio2=((abs(y(2)/taur)*sat)**(xmhigh2-1.))*(y(2)/taur)*sat
       yprime(1)=twomu*(gdotr(1)-a*ratio1-b*ratio2)
       yprime(2)=twomu*(gdotr(2)-c*ratio1-e*ratio2)
       return
       end


  module Mod_nsm_TurbulenceModel
   use typre
   use Mod_PointerSetter
   use Mod_nsm_BaseElmope
   use Mod_nsm_InterpolateGradients
   use Mod_nsm_Viscosity
   implicit none
   private
   public SetPointersTurbulenceModel

   type, extends(PointerSetter) :: SPTurbulenceModel
contains
      procedure :: SpecificSet => SpecificSetTurbulenceModel
   end type
   type(SPTurbulenceModel) :: SetPointersTurbulenceModel

   real(rp) :: vista

contains

   subroutine SpecificSetTurbulenceModel(d)
      implicit none
      class(SPTurbulenceModel) :: d

      !Turbulence model
      if (a%kfl_cotur < 0 ) then
         !Interpolate gradients
         call SetPointersInterpolateGradients%Set
      endif
      !Smagorinsky
      if (a%kfl_cotur == -1) then
         !Modify the viscosity
         call ConcatenateProcedures(ProcHook_PhysicalProp,Smagorinsky)
      !WALE model
      elseif (a%kfl_cotur == -2) then
         !Modify the viscosity
         call ConcatenateProcedures(ProcHook_PhysicalProp,WaleModel)
      endif
   end subroutine

   !---------------------------------------------------------------------------
   !Computation Subroutines
   subroutine Smagorinsky
      implicit none
      call nsm_smago(e,grvel,acden,a%turbu(1),vista)
      acvis = acvis + vista
   end subroutine

   subroutine WaleModel
      implicit none
      call nsm_wale(e,grvel,acden,a%turbu(1),vista)
      acvis = acvis + vista
   end subroutine

end module


! ##################################################################################################################################
! Begin MIT license text.
! _______________________________________________________________________________________________________

! Copyright 2019 Dr William R Case, Jr (dbcase29@gmail.com)

! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
! associated documentation files (the "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to
! the following conditions:

! The above copyright notice and this permission notice shall be included in all copies or substantial
! portions of the Software and documentation.

! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
! _______________________________________________________________________________________________________

! End MIT license text.

      SUBROUTINE CALC_MRRcb

! Calculates the R-set row and col matrix MRRcb in the CB transformation matrix:

!            MRRcb = MRR + MRL*DLR + (MRL*DLR)' + DLR'*MLL*DLR

! For a description of Craig-Bamptom analyses, see Appendix D to the MYSTRAN User's Referance Manual

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE
      USE IOUNT1, ONLY                :  WRT_ERR, WRT_LOG, ERR, F04, F06
      USE SCONTR, ONLY                :  BLNK_SUB_NAM, FATAL_ERR, NDOFL, NDOFR, NTERM_DLR, NTERM_MLL, NTERM_MRL, NTERM_MRR,        &
                                         NTERM_MRRcb, NTERM_MRRcbn
      USE TIMDAT, ONLY                :  TSEC
      USE CONSTANTS_1, ONLY           :  ONE
      USE PARAMS, ONLY                :  SPARSTOR, WTMASS
      USE RIGID_BODY_DISP_MATS, ONLY  :  TR6_MEFM
      USE MODEL_STUF, ONLY            :  MEFM_RB_MASS
      USE SPARSE_MATRICES , ONLY      :  SYM_DLR, SYM_MLL, SYM_MRL, SYM_MRR, SYM_MRRcb

      USE SPARSE_MATRICES , ONLY      :  I_MLL  , J_MLL  , MLL  , I_MRL  , J_MRL  , MRL  , I_MRR  , J_MRR  , MRR  ,                &
                                         I_DLR  , J_DLR  , DLR  , I_DLRt , J_DLRt , DLRt , I_MRRcb, J_MRRcb, MRRcb,                &
                                         SYM_MRRcb

      USE SCRATCH_MATRICES
      USE SUBR_BEGEND_LEVELS, ONLY    :  CALC_MRRcb_BEGEND

      USE CALC_MRRcb_USE_IFs

      IMPLICIT NONE

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: SUBR_NAME = 'CALC_MRRcb'
      CHARACTER(  1*BYTE)             :: SYM_CRS1            ! Storage format for matrix CRS1 (either 'Y' for sym storage or
!                                                              'N' for nonsymmetric storage)
      CHARACTER(  1*BYTE)             :: SYM_CRS3            ! Storage format for matrix CRS3 (either 'Y' for sym storage or
!                                                              'N' for nonsymmetric storage)

      INTEGER(LONG)                   :: AROW_MAX_TERMS      ! Output from MATMULT_SFS_NTERM and input to MATMULT_SFS
      INTEGER(LONG)                   :: I,J                 ! DO loop indices
      INTEGER(LONG)                   :: NTERM_CCS1          ! Number of terms in matrix CCS1
      INTEGER(LONG)                   :: NTERM_CRS1          ! Number of terms in matrix CRS1
      INTEGER(LONG)                   :: NTERM_CRS2          ! Number of terms in matrix CRS2
      INTEGER(LONG)                   :: NTERM_CRS3          ! Number of terms in matrix CRS3
      INTEGER(LONG)                   :: NUM_MRRcb_DIAG_0    ! Number of zero diagonal terms in MRRcb
      INTEGER(LONG), PARAMETER        :: SUBR_BEGEND = CALC_MRRcb_BEGEND

      REAL(DOUBLE)                    :: DUMR6(NDOFR,6)      ! Intermediate matrix
                                                             ! Full representation of MRRcb
      REAL(DOUBLE)                    :: MRRcb_FULL(NDOFR,NDOFR)

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
! Calc MRRcb = MRR + MRL*DLR + (MRL*DLR)' + DLR'*MLL*DLR

      NTERM_MRRcb = NTERM_MRR                              ! First, allocate MRRcb and equate to MRR until we get other terms later
      CALL ALLOCATE_SPARSE_MAT ( 'MRRcb', NDOFR, NTERM_MRRcb, SUBR_NAME )

      DO I=1,NDOFR+1
         I_MRRcb(I) = I_MRR(I)
      ENDDO
      DO J=1,NTERM_MRRcb
         J_MRRcb(J) = J_MRR(J)
           MRRcb(J) =   MRR(J)
      ENDDO
                                                           ! CCS1 will be sparse CCS format version of sparse CRS matrix DLR
      CALL ALLOCATE_SCR_CCS_MAT ( 'CCS1', NDOFR, NTERM_DLR, SUBR_NAME )
      CALL SPARSE_CRS_SPARSE_CCS ( NDOFL, NDOFR, NTERM_DLR, 'DLR', I_DLR, J_DLR, DLR, 'CCS1', J_CCS1, I_CCS1, CCS1, 'Y' )

      IF (NTERM_MRL > 0) THEN                              ! Part I of MRRcb: calc MRL*DLR & add it & transpose to MRR
                                                           ! I-1 , sparse multiply to get CRS1 = MRL*DLR. Use CCS1 for DLR CCS
         CALL MATMULT_SSS_NTERM ( 'MRL' , NDOFR, NTERM_MRL , SYM_MRL, I_MRL, J_MRL,                                                &
                                  'DLR' , NDOFR, NTERM_DLR , SYM_DLR, J_CCS1, I_CCS1, AROW_MAX_TERMS,                              &
                                  'CRS1',        NTERM_CRS1 )

         CALL ALLOCATE_SCR_CRS_MAT ( 'CRS1', NDOFR, NTERM_CRS1, SUBR_NAME )

         CALL MATMULT_SSS ( 'MRL' , NDOFR, NTERM_MRL , SYM_MRL, I_MRL , J_MRL , MRL ,                                              &
                            'DLR' , NDOFR, NTERM_DLR , SYM_DLR, J_CCS1, I_CCS1, CCS1, AROW_MAX_TERMS,                              &
                            'CRS1', ONE  , NTERM_CRS1,          I_CRS1, J_CRS1, CRS1 )

         NTERM_CRS2 = NTERM_CRS1                           ! I-2 , allocate memory to array CRS2 which will hold transpose of CRS1
         CALL ALLOCATE_SCR_CRS_MAT ( 'CRS2', NDOFR, NTERM_CRS2, SUBR_NAME )

                                                           ! I-3 , transpose CRS1 to get CRS2 = (MRL*DLR)t
         CALL MATTRNSP_SS ( NDOFR, NDOFR, NTERM_CRS1, 'CRS1', I_CRS1, J_CRS1, CRS1, 'CRS2', I_CRS2, J_CRS2, CRS2 )

                                                           ! I-4 , sparse add to get CRS3 = CRS1 + CRS2 = (MRL*DLR) + (MRL*DLR)t
         CALL MATADD_SSS_NTERM (NDOFR,'MRL*DLR', NTERM_CRS1, I_CRS1, J_CRS1, 'N', '(MRL*DLR)t', NTERM_CRS2, I_CRS2, J_CRS2, 'N',   &
                                      'CRS3', NTERM_CRS3 )
         CALL ALLOCATE_SCR_CRS_MAT ( 'CRS3', NDOFR, NTERM_CRS3, SUBR_NAME )
         CALL MATADD_SSS ( NDOFR, 'MRL*DLR', NTERM_CRS1, I_CRS1, J_CRS1, CRS1, ONE, '(MRL*DLR)t', NTERM_CRS2, I_CRS2, J_CRS2, CRS2,&
                                  ONE, 'CRS3', NTERM_CRS3, I_CRS3, J_CRS3, CRS3 )

         CALL DEALLOCATE_SCR_MAT ( 'CRS1' )                ! I-5 , deallocate CRS1, CRS2
         CALL DEALLOCATE_SCR_MAT ( 'CRS2' )

                                                           ! I-6 , CRS3 = (MRL*DLR) + (MRL*DLR)t has all nonzero terms in it.
         IF      (SPARSTOR == 'SYM   ') THEN               !       If SPARSTOR == 'SYM   ', rewrite CRS3 as sym in CRS1

            CALL SPARSE_CRS_TERM_COUNT ( NDOFR, NTERM_CRS3, '(MRL*DLR) + (MRL*DLR)t', I_CRS3, J_CRS3, NTERM_CRS1 )
            CALL ALLOCATE_SCR_CRS_MAT ( 'CRS1', NDOFR, NTERM_CRS1, SUBR_NAME )
            CALL CRS_NONSYM_TO_CRS_SYM ( 'CRS3 = (MRL*DLR) + (MRL*DLR)t all nonzeros', NDOFR, NTERM_CRS3, I_CRS3, J_CRS3, CRS3,    &
                                         'CRS1 = (MRL*DLR) + (MRL*DLR)t stored sym'  ,        NTERM_CRS1, I_CRS1, J_CRS1, CRS1 )
            SYM_CRS1 = 'Y'

         ELSE IF (SPARSTOR == 'NONSYM') THEN               !      If SPARSTOR == 'NONSYM', rewrite CRS3 in CRS1 with NTERM_CRS3

            NTERM_CRS1 = NTERM_CRS3
            CALL ALLOCATE_SCR_CRS_MAT ( 'CRS1', NDOFR, NTERM_CRS1, SUBR_NAME )
            DO I=1,NDOFR+1
               I_CRS1(I) = I_CRS3(I)
            ENDDO
            DO I=1,NTERM_CRS1
               J_CRS1(I) = J_CRS3(I)
                 CRS1(I) =   CRS3(I)
            ENDDO
            SYM_CRS1 = 'N'

         ELSE

            WRITE(ERR,932) SUBR_NAME, SPARSTOR
            WRITE(F06,932) SUBR_NAME, SPARSTOR
            FATAL_ERR = FATAL_ERR + 1
            CALL OUTA_HERE ( 'Y' )

         ENDIF

         CALL DEALLOCATE_SCR_MAT ( 'CRS3' )                ! 1-7 , Now CRS1 = (MRL*DLR) + (MRL*DLR)t so deallocate CRS3
         CALL MATADD_SSS_NTERM ( NDOFR, 'MRR', NTERM_MRR, I_MRR, J_MRR, SYM_MRR, 'MRL*DLR + (MRL*DLR)t', NTERM_CRS1,               &
                                 I_CRS1, J_CRS1, SYM_CRS1, 'CRS3', NTERM_CRS3 )
         CALL ALLOCATE_SCR_CRS_MAT ( 'CRS3', NDOFR, NTERM_CRS3, SUBR_NAME )
         CALL MATADD_SSS ( NDOFR, 'MRR', NTERM_MRR, I_MRR, J_MRR, MRR, ONE, 'MRL*DLR + (MRL*DLR)t', NTERM_CRS1,                    &
                           I_CRS1, J_CRS1, CRS1, ONE, 'CRS1', NTERM_CRS3, I_CRS3, J_CRS3, CRS3 )

         CALL DEALLOCATE_SCR_MAT ( 'CRS1' )                ! I-9 , Now CRS3 = MRR + (MRL*DLR) + (MRL*DLR)t so deallocate CRS1

         NTERM_MRRcb = NTERM_CRS3                          ! I-10, allocate MRRcb to be size of CRS1

         CALL DEALLOCATE_SPARSE_MAT ( 'MRRcb' )            ! Reset MRRcb to CRS3 =
         CALL ALLOCATE_SPARSE_MAT ( 'MRRcb', NDOFR, NTERM_MRRcb, SUBR_NAME )
                                                           ! I-11, set MRRcb = CRS3 = MRR + (MRL*DLR) + (MRL*DLR)t
         DO I=1,NDOFR+1
            I_MRRcb(I) = I_CRS3(I)
         ENDDO
         DO J=1,NTERM_MRRcb
            J_MRRcb(J) = J_CRS3(J)
              MRRcb(J) =   CRS3(J)
         ENDDO

         CALL DEALLOCATE_SCR_MAT ( 'CRS3' )                ! I-12, deallocate CRS3

      ENDIF

      IF (NTERM_MLL > 0) THEN                              ! Part II of MRRcb: calc DLR(t)*MLL*DLR and add to MRRcb

                                                           ! II-1 , sparse multiply to get CRS1 = MLL*DLR using CCS1 for DLR CCS
         CALL MATMULT_SSS_NTERM ( 'MLL' , NDOFL, NTERM_MLL , SYM_MLL, I_MLL , J_MLL,                                               &
                                  'DLR' , NDOFR, NTERM_DLR , SYM_DLR, J_CCS1, I_CCS1, AROW_MAX_TERMS,                              &
                                  'CRS1',        NTERM_CRS1 )

         CALL ALLOCATE_SCR_CRS_MAT ( 'CRS1', NDOFL, NTERM_CRS1, SUBR_NAME )

         CALL MATMULT_SSS ( 'MLL ', NDOFL, NTERM_MLL , SYM_MLL, I_MLL, J_MLL, MLL,                                                 &
                            'DLR' , NDOFR, NTERM_DLR , SYM_DLR, J_CCS1, I_CCS1, CCS1, AROW_MAX_TERMS,                              &
                            'CRS1', ONE  , NTERM_CRS1,          I_CRS1, J_CRS1, CRS1 )

         CALL DEALLOCATE_SCR_MAT ( 'CCS1' )                ! II-2 , deallocate CCS1

         NTERM_CCS1 = NTERM_CRS1                           ! II-3 , allocate CCS1 to be same as CRS1 but in CCS format
         CALL ALLOCATE_SCR_CCS_MAT ( 'CCS1', NDOFR, NTERM_CCS1, SUBR_NAME )
         CALL SPARSE_CRS_SPARSE_CCS ( NDOFL, NDOFR, NTERM_CRS1, 'CRS1', I_CRS1, J_CRS1, CRS1, 'CCS1', J_CCS1, I_CCS1, CCS1, 'Y' )

         CALL DEALLOCATE_SCR_MAT ( 'CRS1' )                ! II-4 , deallocate CRS1

                                                           ! II-5 , sparse multiply to get CRS1 = DLRt*CCS1 with CCS1 = MLL*DLR
!                                                                   (note: SYM_DLR used for sym indicator for CCS1)
         CALL MATMULT_SSS_NTERM ( 'DLRt', NDOFR, NTERM_DLR , SYM_DLR, I_DLRt, J_DLRt,                                              &
                                  'CCS1', NDOFR, NTERM_CCS1, SYM_DLR, J_CCS1, I_CCS1, AROW_MAX_TERMS,                              &
                                  'CRS1 ',       NTERM_CRS1 )

         CALL ALLOCATE_SCR_CRS_MAT ( 'CRS1', NDOFR, NTERM_CRS1, SUBR_NAME )

         CALL MATMULT_SSS ( 'DLRt', NDOFR, NTERM_DLR , SYM_DLR, I_DLRt, J_DLRt, DLRt,                                              &
                            'CCS1', NDOFR, NTERM_CCS1, SYM_DLR, J_CCS1, I_CCS1, CCS1, AROW_MAX_TERMS,                              &
                            'CRS1', ONE  , NTERM_CRS1,          I_CRS1, J_CRS1, CRS1 )

         CALL DEALLOCATE_SCR_MAT ( 'CCS1' )                ! II-6 , deallocate CCS1

                                                           ! II-7 , CRS1 = DLRt*MLL*DLR has all nonzero terms in it.
         IF      (SPARSTOR == 'SYM   ') THEN               !        If SPARSTOR == 'SYM   ', rewrite CRS1 as sym in CRS3

            CALL SPARSE_CRS_TERM_COUNT ( NDOFR, NTERM_CRS1, 'DLRt*MLL*DLR all nonzeros', I_CRS1, J_CRS1, NTERM_CRS3 )
            CALL ALLOCATE_SCR_CRS_MAT ( 'CRS3', NDOFR, NTERM_CRS3, SUBR_NAME )
            CALL CRS_NONSYM_TO_CRS_SYM ( 'CRS1 = DLRt*MLL*DLR all nonzeros', NDOFR, NTERM_CRS1, I_CRS1, J_CRS1, CRS1,              &
                                         'CRS3 = DLRt*MLL*DLR stored sym'  ,        NTERM_CRS3, I_CRS3, J_CRS3, CRS3 )
            SYM_CRS3 = 'Y'

         ELSE IF (SPARSTOR == 'NONSYM') THEN               ! If SPARSTOR == 'NONSYM', rewrite CRS3 in CRS1 with NTERM_CRS3

            NTERM_CRS3 = NTERM_CRS1
            CALL ALLOCATE_SCR_CRS_MAT ( 'CRS3', NDOFR, NTERM_CRS3, SUBR_NAME )
            DO I=1,NDOFR+1
               I_CRS3(I) = I_CRS1(I)
            ENDDO
            DO I=1,NTERM_CRS3
               J_CRS3(I) = J_CRS1(I)
                 CRS3(I) =   CRS1(I)
            ENDDO
            SYM_CRS3 = 'N'

         ELSE

            WRITE(ERR,932) SUBR_NAME, SPARSTOR
            WRITE(F06,932) SUBR_NAME, SPARSTOR
            FATAL_ERR = FATAL_ERR + 1
            CALL OUTA_HERE ( 'Y' )

         ENDIF
                                                           ! II-8 , sparse add to get CRS2 = prior MRRcb + CRS3 or
!                                                                   CRS2= MRR + (MRL*DLR) + (MRL*DLR)t + DLRt*MLL*DLR which is MRRcb
         CALL MATADD_SSS_NTERM ( NDOFR, 'MRR', NTERM_MRRcb, I_MRRcb, J_MRRcb, SYM_MRRcb,                                           &
                                        '(MRL*DLR) + (MRL*DLR)t + DLRt*MLL*DLR' , NTERM_CRS3 , I_CRS3 , J_CRS3 , SYM_CRS3,         &
                                        'CRS2' , NTERM_CRS2 )
         CALL ALLOCATE_SCR_CRS_MAT ( 'CRS2', NDOFR, NTERM_CRS2, SUBR_NAME )
         CALL MATADD_SSS ( NDOFR, 'MRR', NTERM_MRRcb, I_MRRcb, J_MRRcb, MRRcb, ONE, 'CRS3', NTERM_CRS3, I_CRS3, J_CRS3, CRS3,      &
                               ONE,'(MRL*DLR) + (MRL*DLR)t + DLRt*MLL*DLR', NTERM_CRS2,  I_CRS2,  J_CRS2,  CRS2 )

         CALL DEALLOCATE_SCR_MAT ( 'CRS1' )                ! II-9 , deallocate CRS1 and CRS3
         CALL DEALLOCATE_SCR_MAT ( 'CRS3' )                ! II-10, deallocate CRS3

         NTERM_MRRcb = NTERM_CRS2                          ! II-11, reallocate MRRcb to be size of CRS2
         CALL DEALLOCATE_SPARSE_MAT ( 'MRRcb' )
         CALL ALLOCATE_SPARSE_MAT ( 'MRRcb', NDOFR, NTERM_MRRcb, SUBR_NAME )

         DO I=1,NDOFR+1                                    ! II-12, set MRRcb = CRS2 until we see if MRL is null, below
            I_MRRcb(I) = I_CRS2(I)
         ENDDO
         DO I=1,NTERM_MRRcb
            J_MRRcb(I) = J_CRS2(I)
              MRRcb(I) =   CRS2(I)
         ENDDO

         CALL DEALLOCATE_SCR_MAT ( 'CRS2' )                ! II-13, deallocate CRS2

      ELSE

         CALL DEALLOCATE_SCR_MAT ( 'CCS1')

      ENDIF

! Calc the 6x6 mass matrix relative to the MEFMGRID and convert it to same units as input mass

      CALL SPARSE_CRS_TO_FULL ( 'MRRcb', NTERM_MRRcb, NDOFR, NDOFR, SYM_MRRcb, I_MRRcb, J_MRRcb, MRRcb, MRRcb_FULL )

      CALL MATMULT_FFF   ( MRRcb_FULL, TR6_MEFM, NDOFR, NDOFR, 6, DUMR6   )
      CALL MATMULT_FFF_T ( TR6_MEFM  , DUMR6   , NDOFR, 6    , 6, MEFM_RB_MASS )
      DO I=1,6
         DO J=1,6
            MEFM_RB_MASS(I,J) = MEFM_RB_MASS(I,J)/WTMASS
         ENDDO
      ENDDO

! The following code sets NTERM_MRRcbn, needed in subr MERGE_MXX. NTERM_MRRcbn cannot wait to be calculated there since several
! arrays have to be dimensioned using it in that subr

      IF      (SPARSTOR == 'SYM   ') THEN                  ! Convert MRRcb (stored symmetric) to MRRcbn (stored nonsymmetric)

         CALL SPARSE_MAT_DIAG_ZEROS ( 'MRRcb', NDOFR, NTERM_MRRcb, I_MRRcb, J_MRRcb, NUM_MRRcb_DIAG_0 )
         NTERM_MRRcbn = 2*NTERM_MRRcb  - (NDOFR - NUM_MRRcb_DIAG_0)

      ELSE IF (SPARSTOR == 'NONSYM') THEN

         NTERM_MRRcbn = NTERM_MRRcb                        ! If SPARSTOR is nonsym, then MRRcb is also stored nonsym

      ELSE

         WRITE(ERR,932) SUBR_NAME, SPARSTOR
         WRITE(F06,932) SUBR_NAME, SPARSTOR
         FATAL_ERR = FATAL_ERR + 1
         CALL OUTA_HERE ( 'Y' )

      ENDIF

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

! **********************************************************************************************************************************
  932 FORMAT(' *ERROR   932: PROGRAMMING ERROR IN SUBROUTINE ',A                                                                   &
                    ,/,14X,' PARAMETER SPARSTOR MUST BE EITHER "SYM" OR "NONSYM" BUT VALUE IS ',A)

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

      END SUBROUTINE CALC_MRRcb


program main
  implicit none

  !===> setting of speedy
  integer, parameter :: nlon  = 96
  integer, parameter :: nlat  = 48
  integer, parameter :: nlev  =  7
  integer, parameter :: nhour =  6
  real(8), parameter :: dx    = 3.75d0

  !===> setting of constant parameter
  real(4), parameter :: undef4 = -9.99d33
  real(8), parameter :: undef8 = -9.99d33
  real(8), parameter :: pi     =  3.1415926535d0
  real(8), parameter :: pi_180 = pi / 180.0d0
  REAL(8), PARAMETER :: lfactor     = 2.0d0*dsqrt(10.0d0/3.0d0)

  !===>speedy.cnf
  integer,        save :: adate, sdate, edate, pdate, qdate
  integer,        save :: nbv, nrunme
  character(255), save :: natdir, spndir, expdir, outtime, outtave, expname, obsname, cneff, crtps

  !===> save variables
  integer, save :: nsamp, nrec, nmax

  !====> global variables
  integer :: idate, m, mm, i, j, ii, jj, k, kk, irec, icon, igrd, timer
  real(8) :: asamp, psamp, www
  real(8) :: clon(nlon), clat(nlat)

  character(255) :: truname, emename, espname, pefname, outfile
  character(2)   :: CRGN
  logical :: ex

  integer, parameter :: tmax = 99999
  real(8) :: epeff, epeff_tave, epeff_t(tmax)
  real(8) :: ermse, ermse_tave, ermse_t(tmax)
  real(8) :: esprd, esprd_tave, esprd_t(tmax)

  real(4) :: tru(nlon,nlat), eme(nlon,nlat), esp(nlon,nlat), erm(nlon,nlat)
  real(4) :: pef(nlon,nlat)

  real(4) :: erm_a, esp_a

  real(4) :: anal(nlon,nlat), true(nlon,nlat), rmse(nlon,nlat), sprd(nlon,nlat), diff(nlon,nlat)

  real(4) :: tmp4(nlon,nlat)
  real(8) :: tmp8(nlon,nlat)

  namelist / speedy_param / adate, sdate, edate, pdate, qdate, nbv, nrunme, &
                            natdir, spndir, expdir, outtime, outtave, expname, obsname, cneff, crtps
  !================================================================================================== (1) PREPARATION
  open(1,file="speedy.cnf")
  	read(1,nml=speedy_param)
  close(1)

  !=====> (1) preparation
  !print '(2a)', "  Calc... Standard  RMSE"
  do i=1,nlon  ;  clon(i) = 0.0d0 + dble(i-1) * dx   ;  end do
  call get_clat( nlat, clat )
  !==================================================================================================

  print '(3a)',">>>>>================================================   calc... RMSE&SPRD  ===============================================<<<<< "
  !!write(outfile,'(6a)') trim(outdir),"/time_",trim(obsname),"_",trim(expname),".txt"
  !!open(1,file=trim(outfile),form="formatted",action="write")
  open(1,file=trim(outtime),form="formatted",action="write")

  !=====> (2) get nsamp & RMSE
  idate = adate ! initial time
  nsamp = 0
  timer = 0
  erm_a = 0.0d0  ;  esp_a = 0.0d0

  rmse  = 0.0d0
  sprd  = 0.0d0
  ermse_t(:) = undef8  ;  esprd_t(:) = undef8
  epeff_t(:) = undef8
  do
    if( mod( idate,10000 )==100 ) &
      print '(5a,i10)',"      calc... RMSE&SPRD  ===>> ", trim(obsname)," ",trim(expdir)," :: ",idate

    timer = timer + 1
      write(truname,'(1a,i10.10,a)') trim(natdir),                 idate,".grd"
    if( idate < sdate )then
      write(emename,'(2a,i10.10,a)') trim(spndir),"/gues/mean/",   idate,".grd"
      write(espname,'(2a,i10.10,a)') trim(spndir),"/gues/sprd/",   idate,".grd"
    else
      write(emename,'(2a,i10.10,a)') trim(expdir),"/gues/mean/",   idate,".grd"
      write(espname,'(2a,i10.10,a)') trim(expdir),"/gues/sprd/",   idate,".grd"
      write(pefname,'(2a,i10.10,a)') trim(expdir),"/peff_lpf/",    idate,".grd"
    endif
    !!!print '(i10,x,a)', idate, trim(ename)

    ! U(7), V(7), T(7), P(7), Ps(2), Rain(2)
    k = 18 ! 4th level of T
    !!!k =  4 ! 4th level of U (to compare with Kondo and Miyoshi 2016)

    open(10,file=trim(truname),form="unformatted",access="direct",recl=nlon*nlat*4,action="read")
      read(10,rec=k) tru(:,:)
    close(10)

    inquire(FILE=trim(emename),EXIST=ex)

    if( ex .or. idate<=(sdate+700) ) then ! at least one week
      open(11,file=trim(emename),form="unformatted",access="direct",recl=nlon*nlat*4,action="read")
      open(12,file=trim(espname),form="unformatted",access="direct",recl=nlon*nlat*4,action="read")
        read(11,rec=k) eme(:,:)
        read(12,rec=k) esp(:,:)
      close(11) ; close(12)
    else
      eme(:,:) = undef4
      esp(:,:) = undef4
      print '(2a)', " maybe because of divergence, cannot find file :: ", trim(emename)
    endif

    if( idate >= sdate ) then
      inquire(FILE=trim(pefname),EXIST=ex)
      if( ex )then
        open(20,file=trim(pefname),form="unformatted",access="direct",recl=nlon*nlat*4,action="read")
          read(20,rec=k) pef(:,:)
        close(20)
      else
        pef(:,:) = undef4
      end if
    else
      pef(:,:) = dble(nbv)
    end if

    !===> for all time (global-mean rmse)
    ermse = 0.0d0 ; esprd = 0.0d0
    epeff = 0.0d0
    asamp = 0.0d0 ; psamp = 0.0d0
    do j=1,nlat
      www = dcos( clat(j)*pi_180 )
      do i=1,nlon
          asamp = asamp + www
          ermse = ermse + www * ( eme(i,j) - tru(i,j) )**2.0d0
          esprd = esprd + www * ( esp(i,j)            )**2.0d0
        if( 0.0d0<=pef(i,j) .and. pef(i,j)<=dble(nbv) )then
          psamp = psamp + www
          epeff = epeff + www *   pef(i,j)
        end if
      end do
    end do

    ermse = dsqrt( ermse / asamp )  ;  esprd = dsqrt( esprd / asamp )
    epeff =        epeff / psamp
    ermse_t(timer) = ermse          ;  esprd_t(timer) = esprd
    epeff_t(timer) = epeff

    ermse_tave = undef8 ; if( timer >=nrunme ) ermse_tave = sum( ermse_t(timer-nrunme+1:timer) ) / dble( nrunme )
    esprd_tave = undef8 ; if( timer >=nrunme ) esprd_tave = sum( esprd_t(timer-nrunme+1:timer) ) / dble( nrunme )
    epeff_tave = undef8 ; if( timer >=nrunme ) epeff_tave = sum( epeff_t(timer-nrunme+1:timer) ) / dble( nrunme )

    if( timer>= nrunme ) &
    write(1,'(2i12,f9.3,4f8.4,2f8.2)')                                     &
                                idate, timer, real(timer)/4.0d0,           &
                                ermse, esprd, ermse_tave, esprd_tave, epeff, epeff_tave
    !write(6,'(2i12,f9.3,4f8.4,2f8.2)')                                     &
    !                            idate, timer, real(timer)/4.0d0,           &
    !                            ermse, esprd, ermse_tave, esprd_tave, epeff, epeff_tave

    !===> for time-mean rmse
    if( pdate<=idate .and. idate<=qdate )then
      nsamp = nsamp + 1
      erm_a = erm_a + ermse
      esp_a = esp_a + esprd
    endif

    call update_date(idate,nhour)
    if ( nsamp .ge. 10000 ) then
      write(6,*) 'nsamp is too large'
      stop
    end if
    if( idate > edate  ) goto 10
  end do
10 continue
  close(1)

  erm_a = erm_a / dble( nsamp )
  esp_a = esp_a / dble( nsamp )
  if( .not. (0.0d0<abs(erm_a) .and. abs(erm_a)<999.9d0) ) erm_a = 999.9d0
  if( .not. (0.0d0<abs(esp_a) .and. abs(esp_a)<999.9d0) ) esp_a = 999.9d0
!  write(outfile,'(6a,i10.10,a,i10.10,a)') trim(outdir),"/tave_",trim(obsname),"_",trim(expname),"_SMP",sdate,"-",edate,".txt"
!  open(1,file=trim(outfile),form="formatted",action="write")
  open(1,file=trim(outtave),form="formatted",action="write")
    write(1,'(a,x,a,x,i12,4f10.4)') trim(cneff), trim(crtps), nsamp, erm_a, esp_a
  close(1)

1111 continue

end
!=========================================================
subroutine calc_dist_deg(xlon1,xlon2,xlat1,xlat2,dist)
!=========================================================
  implicit none
  double precision xlon1,xlon2,xlat1,xlat2
  double precision lon1,lon2,lat1,lat2,cosd,dist

  REAL(8),PARAMETER :: pi=3.1415926535d0
  REAL(8),PARAMETER :: re=6371.3d3
  REAL(8),PARAMETER :: r180=1.0d0/180.0d0

  lon1 = xlon1 * pi * r180 ! [rad]
  lon2 = xlon2 * pi * r180 ! [rad]
  lat1 = xlat1 * pi * r180 ! [rad]
  lat2 = xlat2 * pi * r180 ! [rad]

  cosd = SIN(lat1)*SIN(lat2) + COS(lat1)*COS(lat2)*COS(lon2-lon1)
  cosd = MIN( 1.d0,cosd)
  cosd = MAX(-1.d0,cosd)
  dist = ACOS( cosd ) * re

end
!=========================================================
subroutine update_date(date,nhour)
!=========================================================
  implicit none
  integer date,nhour,date1
  integer year,mon,day,hour,mondays

  date1 = date
  year = int( date / 1000000 )  ;  date = date - year * 1000000
  mon  = int( date / 10000 )    ;  date = date - mon  * 10000
  day  = int( date / 100 )      ;  hour = date - day * 100

  hour = hour + nhour

10 continue
  if( hour.ge.24 ) then
    hour = hour - 24
    day  = day + 1
    call get_mondays(year,mon,mondays)
    if ( day.gt.mondays ) then
      day = 1
      mon = mon + 1
      if( mon.ge.13 ) then
        mon = 1
        year = year + 1
      end if ! mon
    end if ! day
  end if ! hour
  if( hour.ge.24 ) goto 10

  date = year*1000000 + mon*10000 + day*100 + hour
end subroutine update_date

!=========================================================
subroutine get_mondays(year,mon,mondays)
!=========================================================
  implicit none
  integer year,mon,mondays

  mondays=31
  if( mon ==  4 ) mondays = 30
  if( mon ==  6 ) mondays = 30
  if( mon ==  9 ) mondays = 30
  if( mon == 11 ) mondays = 30
  if( mon ==  2 ) then
    mondays = 28
    if( mod(year,4)==0 ) mondays = 29
  end if
end subroutine get_mondays
!=========================================================
subroutine get_clat(nlat,clat)
!=========================================================
implicit none
  integer, intent(in)  :: nlat
  real(8), intent(out) :: clat(nlat)

  clat(01)=-87.159  ;  clat(02)=-83.479  ;  clat(03)=-79.777  ;  clat(04)=-76.070  ;  clat(05)=-72.362  ;  clat(06)=-68.652
  clat(07)=-64.942  ;  clat(08)=-61.232  ;  clat(09)=-57.521  ;  clat(10)=-53.810  ;  clat(11)=-50.099  ;  clat(12)=-46.389
  clat(13)=-42.678  ;  clat(14)=-38.967  ;  clat(15)=-35.256  ;  clat(16)=-31.545  ;  clat(17)=-27.833  ;  clat(18)=-24.122
  clat(19)=-20.411  ;  clat(20)=-16.700  ;  clat(21)=-12.989  ;  clat(22)=- 9.278  ;  clat(23)=- 5.567  ;  clat(24)=- 1.856
  clat(25)=  1.856  ;  clat(26)=  5.567  ;  clat(27)=  9.278  ;  clat(28)= 12.989  ;  clat(29)= 16.700  ;  clat(30)= 20.411
  clat(31)= 24.122  ;  clat(32)= 27.833  ;  clat(33)= 31.545  ;  clat(34)= 35.256  ;  clat(35)= 38.967  ;  clat(36)= 42.678
  clat(37)= 46.389  ;  clat(38)= 50.099  ;  clat(39)= 53.810  ;  clat(40)= 57.521  ;  clat(41)= 61.232  ;  clat(42)= 64.942
  clat(43)= 68.652  ;  clat(44)= 72.362  ;  clat(45)= 76.070  ;  clat(46)= 79.777  ;  clat(47)= 83.479  ;  clat(48)= 87.159
end subroutine get_clat


PROGRAM vectorAdd

    use nvtx

    IMPLICIT NONE

    INTEGER, PARAMETER :: N = 2 ** 20

    REAL(KIND=8), ALLOCATABLE, DIMENSION(:) :: a, b, c
    INTEGER :: i

    call nvtxStartRange("vectorAdd")

    allocate (a(N), b(N), c(N))

    CALL RANDOM_NUMBER(a)
    CALL RANDOM_NUMBER(b)

    call nvtxStartRange("INIT ACC")
    !$acc init
    call nvtxEndRange

    call nvtxStartRange("ACC PARALLEL 1")
    !$acc parallel
    !$acc loop gang vector
    DO i=1, N
        c(i) = a(i) + b(i)
    END DO
    !$acc end parallel
    call nvtxEndRange

    call nvtxStartRange("ACC PARALLEL 2")
    !$acc parallel
    !$acc loop gang vector
    DO i=1, N
        c(i) = a(i) + b(i)
    END DO
    !$acc end parallel
    call nvtxEndRange

    call nvtxStartRange("ACC PARALLEL 3")
    !$acc parallel num_gangs(1024)
    !$acc loop gang vector
    DO i=1, N
        c(i) = a(i) + b(i)
    END DO
    !$acc end parallel
    call nvtxEndRange

    print *, "SUM(C) = ", SUM(C)

    deallocate (a, b, c)

    call nvtxEndRange

END PROGRAM


PROGRAM QA1
! (LICENSE:Public Domain)
   USE M_calcomp
   CHARACTER * 10 ICHR1
   CHARACTER * 14 ICHR2,ICHR3
   CHARACTER * 5  ICHR4,ICHR6
   CHARACTER * 4  ICHR5,ICHR7
   CHARACTER * 29 ICHR8
   CHARACTER * 32 ICHR9,ICHR10,ICHR11,ICHR12
   CHARACTER * 1 IBCD
   ICHR1='WIDTH (FT)'
   ICHR2='THICKNESS (IN)'
   ICHR3='PRESSURE (PSI)'
   ICHR4='THK= '
   ICHR5=' IN.'
   ICHR6='WTH= '
   ICHR7=' FT.'
   ICHR8='CRITICAL BUCKLING PRESSURE OF'
   ICHR9='HYPERBOLIC PARABOLOID SHELLS FOR'
   ICHR10='FIXED WIDTH VS VARYING THICKNESS'
   ICHR11='FIXED THICKNESS VS VARYING WIDTH'
   ICHR12='PREPARED ON A CALCOMP PLOTTER'
   CALL PLOTS(0.0,24.0,0.0,12.0)
! ESTABLISH AN ORIGIN SO NEGATIVE VALUES UP TO -0.5 MAY BE USED
   CALL PLOT(0.5,0.5,-3)
! PLOT X-AXIS FOR WIDTH
   X=0.0
   DO I=1,10
      CALL PLOT(X,0.0,3)
      X=X+1.0
      CALL PLOT(X,0.0,2)
      CALL PLOT(X,-.1,2)
      CALL NUMBER(X,-0.25,0.1,5.0*X,0.0,-1)
   ENDDO
   CALL SYMBOL(4.0,-0.40,0.12,IBCD,1,0.0,-1)
   CALL SYMBOL(4.2,-0.45,0.14,ICHR1,INTEQ,0.0,10)
   CALL PLOT (0.0,0.5,-3)
! PLOT X-AXIS FOR THICKNESS
   X=0.0
   DO I=1,5
      CALL PLOT(X,0.0,3)
      X=X+1.0
      CALL PLOT(X,0.0,2)
      CALL PLOT(X,-.1,2)
      CALL PLOT(X,0.0,2)
      X=X+1.0
      CALL PLOT(X,0.0,2)
      CALL PLOT(X,-.1,2)
      CALL NUMBER(X,-0.25,0.1,X,0.0,-1)
   enddo
   CALL SYMBOL(3.7,-0.40,0.12,IBCD,7,0.0,-1)
   CALL SYMBOL(4.0,-0.45,0.14,ICHR2,INTEQ,0.0,14)
! PLOT Y-AXIS
   Y=0.0
   DO I=1,9
      CALL PLOT(0.0,Y,3)
      Y=Y+1.0
      CALL PLOT(0.0,Y,2)
      CALL PLOT(-.1,Y,2)
      CALL NUMBER(-.15,Y-.2,0.1,1000.*Y,90.0,0)
   enddo
   CALL SYMBOL(-0.30,3.5,0.14,ICHR3,INTEQ,90.0,14)
   THICK=3.0
   WDTH=25.0
   DO I=1,3
      TSQR=THICK*THICK
      WSQR=WDTH*WDTH
      PSI=100.99*TSQR
      CALL SYMBOL(0.6,PSI/1000.0,0.1,ICHR4,INTEQ,0.0,5)
      CALL NUMBER(999.0,999.0,0.10,THICK,0.0,0)
      CALL SYMBOL(999.0,999.0,0.10,ICHR5,INTEQ,0.0,4)
      CALL SYMBOL( 2.0 ,999.0,0.12,IBCD,1,0.0,-1)
      DO J=10,50
         WX=real(J)
         PSI=10099.0*TSQR/(WX*WX)
         CALL PLOT(WX/5.0,PSI/1000.0,2)
      enddo
      PSI=10099.0*81.0/WSQR
      CALL SYMBOL(9.2,PSI/1000.0,0.1,ICHR6,INTEQ,0.0,5)
      CALL NUMBER(999.0,999.0,0.10,WDTH,0.0,0)
      CALL SYMBOL(999.0,999.0,0.10,ICHR7,INTEQ,0.0,4)
      CALL SYMBOL( 9.0 ,999.0,0.12,IBCD,7,0.0,-1)
      DO J=5,50
         TX=real(J)
         TX=(50.0-TX)/5.0
         PSI=10099.0*TX*TX/WSQR
         CALL PLOT(TX,PSI/1000.0,2)
      enddo
      THICK=THICK+3.0
      WDTH=WDTH-5.0
   enddo
   CALL SYMBOL(3.3,8.5,.14,ICHR8,INTEQ,0.,29)
   CALL SYMBOL(3.1,8.2,.14,ICHR9,INTEQ,0.,32)
   CALL SYMBOL(3.1,7.9,.14,ICHR10,INTEQ,0.,32)
   CALL SYMBOL(3.1,7.6,.14,ICHR11,INTEQ,0.,32)
   CALL SYMBOL(3.3,7.0,.14,ICHR12,INTEQ,0.,29)
   CALL PLOT(0.0,0.0,999)
   STOP
END PROGRAM QA1


      subroutine fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa)
      integer m,n,ldfjac,iflag
      double precision epsfcn
      double precision x(n),fvec(m),fjac(ldfjac,n),wa(m)
c     **********
c
c     subroutine fdjac2
c
c     this subroutine computes a forward-difference approximation
c     to the m by n jacobian matrix associated with a specified
c     problem of m functions in n variables.
c
c     the subroutine statement is
c
c       subroutine fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa)
c
c     where
c
c       fcn is the name of the user-supplied subroutine which
c         calculates the functions. fcn must be declared
c         in an external statement in the user calling
c         program, and should be written as follows.
c
c         subroutine fcn(m,n,x,fvec,iflag)
c         integer m,n,iflag
c         double precision x(n),fvec(m)
c         ----------
c         calculate the functions at x and
c         return this vector in fvec.
c         ----------
c         return
c         end
c
c         the value of iflag should not be changed by fcn unless
c         the user wants to terminate execution of fdjac2.
c         in this case set iflag to a negative integer.
c
c       m is a positive integer input variable set to the number
c         of functions.
c
c       n is a positive integer input variable set to the number
c         of variables. n must not exceed m.
c
c       x is an input array of length n.
c
c       fvec is an input array of length m which must contain the
c         functions evaluated at x.
c
c       fjac is an output m by n array which contains the
c         approximation to the jacobian matrix evaluated at x.
c
c       ldfjac is a positive integer input variable not less than m
c         which specifies the leading dimension of the array fjac.
c
c       iflag is an integer variable which can be used to terminate
c         the execution of fdjac2. see description of fcn.
c
c       epsfcn is an input variable used in determining a suitable
c         step length for the forward-difference approximation. this
c         approximation assumes that the relative errors in the
c         functions are of the order of epsfcn. if epsfcn is less
c         than the machine precision, it is assumed that the relative
c         errors in the functions are of the order of the machine
c         precision.
c
c       wa is a work array of length m.
c
c     subprograms called
c
c       user-supplied ...... fcn
c
c       minpack-supplied ... dpmpar
c
c       fortran-supplied ... dabs,dmax1,dsqrt
c
c     argonne national laboratory. minpack project. march 1980.
c     burton s. garbow, kenneth e. hillstrom, jorge j. more
c
c     **********
      integer i,j
      double precision eps,epsmch,h,temp,zero
      double precision dpmpar
      external fcn
      data zero /0.0d0/
c
c     epsmch is the machine precision.
c
      epsmch = dpmpar(1)
c
      eps = dsqrt(dmax1(epsfcn,epsmch))
      do 20 j = 1, n
         temp = x(j)
         h = eps*dabs(temp)
         if (h .eq. zero) h = eps
         x(j) = temp + h
         call fcn(m,n,x,wa,iflag)
         if (iflag .lt. 0) go to 30
         x(j) = temp
         do 10 i = 1, m
            fjac(i,j) = (wa(i) - fvec(i))/h
   10       continue
   20    continue
   30 continue
      return
c
c     last card of subroutine fdjac2.
c
      end


CS    REAL FUNCTION BESK1(X)
      DOUBLE PRECISION FUNCTION BESK1(X)
C--------------------------------------------------------------------
C
C This function program computes approximate values for the
C   modified Bessel function of the second kind of order one
C   for arguments  XLEAST .LE. ARG .LE. XMAX.
C
C--------------------------------------------------------------------
      INTEGER JINT
CS    REAL
      DOUBLE PRECISION
     1    X, RESULT
C--------------------------------------------------------------------
      JINT = 1
      CALL CALCK1(X,RESULT,JINT)
      BESK1 = RESULT
      RETURN
C---------- Last line of BESK1 ----------
      END


! This file is part of NHDS
! Copyright (C) 2020 Daniel Verscharen (d.verscharen@ucl.ac.uk)
!All rights reserved.
!
!Redistribution and use in source and binary forms, with or without
!modification, are permitted provided that the following conditions are met:
!
!1. Redistributions of source code must retain the above copyright notice, this
!   list of conditions and the following disclaimer.
!2. Redistributions in binary form must reproduce the above copyright notice,
!   this list of conditions and the following disclaimer in the documentation
!   and/or other materials provided with the distribution.
!
!THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
!ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
!WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
!DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
!ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
!(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
!LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
!ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
!(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
!SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
!The views and conclusions contained in the software and documentation are those
!of the authors and should not be interpreted as representing official policies,
!either expressed or implied, of the NHDS project.

subroutine calc_xi(xi,j,pol,polz,x,kz,kperp)
use input_params
implicit none
double precision :: kz,kperp
double complex :: x,pol,polz,Avec(3),xi,chi(3,3)
integer :: j

! This subroutine calculates the quantity xi in dn/n_0 = xi * dB_(x,y,z)/B_0

if (ampl_mode.EQ.1) then
	! Avec fulfills the equation  c * dE = Avec * vA * dB_x
	Avec(1)=uniti*x/(kz*pol)
	Avec(2)=-x/kz
	Avec(3)=polz*uniti*x/(kz*pol)
else if (ampl_mode.EQ.2) then
	! Avec fulfills the equation  c * dE = Avec * vA * dB_y
	Avec(1)=x/(kz-polz*kperp)
	Avec(2)=uniti*pol*x/(kz-polz*kperp)
	Avec(3)=x/((kz/polz)-kperp)
else if (ampl_mode.EQ.3) then
	! Avec fulfills the equation  c * dE = Avec * vA * dB_z
	Avec(1)=-uniti*x/(kperp*pol)
	Avec(2)=x/kperp
	Avec(3)=-uniti*x*polz/(kperp*pol)
endif

call calc_chi(chi,j,kz,kperp,x)

! continuity equation (as in Stix 10-75)
xi=kperp*(chi(1,1)*Avec(1)+chi(1,2)*Avec(2)+chi(1,3)*Avec(3))
xi=xi+kz*(chi(3,1)*Avec(1)+chi(3,2)*Avec(2)+chi(3,3)*Avec(3))
xi=-uniti*xi*ampl/(x*x*density(j)*charge(j))

! Normalization: chi is different by a factor vAc*vAc from Stix' definition:
! our chi divided by (v_A/c)^2 ond x^2 is equal to Stix' chi.

end subroutine

subroutine calc_fluctRj(dpperp,dppar,dUperpx,dUperpy,dUpar,j,pol,polz,x,kz,kperp)
use input_params
implicit none
double precision :: kz,kperp,z,besselI,BInz,dBInzdz,d2BInzdz2
double complex :: x,pol,polz,Avec(3),dispfunct,zeta,chi(3,3)
double complex :: Z0,Z1,Z2,Z3,dpperp,dppar,Exterm,Eyterm,Ezterm,dUpar
double complex :: dUperpx,dUperpy,Ubar
logical :: kpos,Bessel_run
integer :: j,n,nmaxrun

! This subroutine calculates the pressure fluctuations that are
! needed to calculate the quantity R_j (the fluctuations in the temperature anisotropy of species j)
! define ampl = dBz/B0

z=0.5d0*(kperp*vtherm(j)/Omega(j))*(kperp*vtherm(j)/Omega(j))*alpha(j)

kpos=.TRUE.
if (kz.LT.0.d0) kpos=.FALSE.

if (ampl_mode.EQ.1) then
	! Avec fulfills the equation  c * dE = Avec * vA * dB_x
	Avec(1)=uniti*x/(kz*pol)
	Avec(2)=-x/kz
	Avec(3)=polz*uniti*x/(kz*pol)
else if (ampl_mode.EQ.2) then
	! Avec fulfills the equation  c * dE = Avec * vA * dB_y
	Avec(1)=x/(kz-polz*kperp)
	Avec(2)=uniti*pol*x/(kz-polz*kperp)
	Avec(3)=x/((kz/polz)-kperp)
else if (ampl_mode.EQ.3) then
	! Avec fulfills the equation  c * dE = Avec * vA * dB_z
	Avec(1)=-uniti*x/(kperp*pol)
	Avec(2)=x/kperp
	Avec(3)=-uniti*x*polz/(kperp*pol)
endif

! This is for the calculation of dUpar and dUperp from the definition of the current density
! and the susceptibility. These expressions are equivalent to taking the first moment
! of delta f and lead to the same result.
call calc_chi(chi,j,kz,kperp,x)
dUpar=chi(3,1)*Avec(1)+chi(3,2)*Avec(2)+chi(3,3)*Avec(3)
dUpar=-uniti*dUpar*ampl/(x*density(j)*charge(j))

dUperpx=chi(1,1)*Avec(1)+chi(1,2)*Avec(2)+chi(1,3)*Avec(3)
dUperpx=-uniti*dUperpx*ampl/(x*density(j)*charge(j))

dUperpy=chi(2,1)*Avec(1)+chi(2,2)*Avec(2)+chi(2,3)*Avec(3)
dUperpy=-uniti*dUperpy*ampl/(x*density(j)*charge(j))

! This is without dUpar:
Ubar=vdrift(j)!+dUpar

! Normalization: chi is different by a factor vAc*vAc from Stix' definition:
! our chi divided by (v_A/c)^2 and by x^2 is equal to Stix' chi.

! dUperpx and dUperpy need to be small so that the following calculation is accurate.

!determine maximum n for Besselfunction:
nmaxrun=nmax
n=0
Bessel_run=.TRUE.
do while (Bessel_run)
  if ((n.GE.nmax).OR.(besselI(n,z).LT.Bessel_zero)) then
     nmaxrun=n
     Bessel_run=.FALSE.
  endif
  n=n+1
enddo

if ((n.GE.nmax).AND.(output_warning)) then
 write (*,*) "WARNING: Insufficient order of Bessel function (nmax)."
 stop
endif

! dpperp is deltapperp in units of the magnetic background pressure
! dppar is deltappar in units of the magnetic background pressure.

dpperp=0.d0
dppar=0.d0

! Run over all n:
do n=-nmaxrun,nmaxrun

	if (n.GE.0) then
		BInz=1.d0*besselI(n,z)
		dBInzdz=besselI(n+1,z)+1.d0*n*BInz/z
	else
		BInz=1.d0*besselI(-n,z)
		dBInzdz=besselI(-n-1,z)+1.d0*n*BInz/z
	endif

	if (n.GE.2) d2BInzdz2=0.25d0*(besselI(n-2,z)+2.d0*besselI(n,z)+besselI(n+2,z))
	if (n.LE.-2) d2BInzdz2=0.25d0*(besselI(2-n,z)+2.d0*besselI(-n,z)+besselI(-2-n,z))
	if (n.EQ.1) d2BInzdz2=0.25d0*(3.d0*besselI(1,z)+besselI(3,z))
	if (n.EQ.-1) d2BInzdz2=0.25d0*(besselI(3,z)+3.d0*besselI(1,z))
	if (n.EQ.0) d2BInzdz2=0.5d0*(besselI(2,z)+besselI(0,z))

	zeta=(x-kz*vdrift(j)-1.d0*n*Omega(j))/(kz*vtherm(j))

	! determine Stix' (normalized) dispersion functions:
	! (normalized as follows: Z0, Z1/vA, Z2*vA^2, Z3*vA^3)
	Z0=dispfunct(zeta,kpos)
	Z1=vtherm(j)*(1.d0+(zeta+vdrift(j)/vtherm(j))*Z0)
	Z2=(zeta+2.d0*vdrift(j)/vtherm(j)+Z0*(zeta+vdrift(j)/vtherm(j))**(2.d0))
	Z2=Z2*vtherm(j)*vtherm(j)
	Z3=0.5d0+zeta*zeta+3.d0*zeta*vdrift(j)/vtherm(j)+3.d0*(vdrift(j)/vtherm(j))**(2.d0)
	Z3=Z3+Z0*(zeta+vdrift(j)/vtherm(j))**(3.d0)
	Z3=Z3*vtherm(j)*vtherm(j)*vtherm(j)

	! This is for the calculation of dpperp:

	Exterm=Avec(1)*(BInz+z*(dBinzdz-BInz))*(1.d0*n)*Omega(j)/kperp
	Eyterm=-uniti*Avec(2)*(BInz-dBInzdz-0.5d0*z*(BInz+d2BInzdz2)+z*dBInzdz)
	Eyterm=Eyterm*kperp*vtherm(j)*vtherm(j)*alpha(j)/Omega(j)
	Ezterm=(1.d0-1.d0*n*Omega(j)/x)*alpha(j)*(Z1-vdrift(j)*Z0)+1.d0*n*Omega(j)*Z1/x
	Ezterm=Ezterm*Avec(3)*(BInz+z*(dBInzdz-BInz))

	dpperp=dpperp+(Exterm+Eyterm)*(Z0-kz*Z1/x+alpha(j)*kz*(Z1-vdrift(j)*Z0)/x)+Ezterm

	! This is for the calculation of dppar:

	Exterm=alpha(j)*kz*(Z3-vdrift(j)*Z2-2.d0*Ubar*Z2+2.d0*vdrift(j)*Ubar*Z1+Ubar*Ubar*Z1-vdrift(j)*Ubar*Ubar*Z0)/x
	Exterm=Exterm+Z2-2.d0*Ubar*Z1+Ubar*Ubar*Z0
	Exterm=Exterm-kz*(Z3-2.d0*Ubar*Z2+Ubar*Ubar*Z1)/x
	Exterm=Exterm*Avec(1)*BInz*(1.d0*n)*Omega(j)/(kperp*vtherm(j)*vtherm(j)*alpha(j))
	Eyterm=alpha(j)*kz*(Z3-vdrift(j)*Z2-2.d0*Ubar*Z2+2.d0*vdrift(j)*Ubar*Z1+Ubar*Ubar*Z1-vdrift(j)*Ubar*Ubar*Z0)/x
	Eyterm=Eyterm+Z2-2.d0*Ubar*Z1+Ubar*Ubar*Z0
	Eyterm=Eyterm-kz*(Z3-2.d0*Ubar*Z2+Ubar*Ubar*Z1)/x
	Eyterm=-uniti*Eyterm*Avec(2)*(BInz-dBInzdz)*kperp/(2.d0*Omega(j))
	Ezterm=(1.d0-(1.d0*n)*Omega(j)/x)*(Z3-vdrift(j)*Z2-2.d0*Ubar*Z2+2.d0*vdrift(j)*Ubar*Z1+Ubar*Ubar*Z1-vdrift(j)*Ubar*Ubar*Z0)
	Ezterm=Ezterm+(1.d0*n)*Omega(j)*(Z3-2.d0*Ubar*Z2+Ubar*Ubar*Z1)/(alpha(j)*x)
	Ezterm=Ezterm*Avec(3)*BInz/(vtherm(j)*vtherm(j))

	dppar=dppar+Exterm+Eyterm+Ezterm

enddo

dpperp=-2.d0*uniti*ampl*mass(j)*density(j)*Omega(j)*dpperp*exp(-z)/(kz*vtherm(j))
dppar=-4.d0*uniti*ampl*mass(j)*density(j)*Omega(j)*dppar*exp(-z)/(kz*vtherm(j))

end subroutine


C * * * * * * * * * * * * * * * * * * * * * * * * *
C --- DRIVER FOR RADAU5 ON BEAM PROBLEM
C * * * * * * * * * * * * * * * * * * * * * * * * *
        IMPLICIT REAL*8 (A-H,O-Z)
C --- PARAMETERS FOR RADAU5 (FULL JACOBIAN)
        PARAMETER (ND=80,LWORK=4*ND*ND+12*ND+20,LIWORK=3*ND+20)
        COMMON/NNNN/NCOM,NNCOM,NSQ,NQUATR,DELTAS
        DIMENSION Y(ND),WORK(LWORK),IWORK(LIWORK)
C -------- END PARAMETER LIST --------
        REAL*4 TARRAY(2),TRESULT
        EXTERNAL FTIGE,SOLOUT
c ------ FILE DE DONNEES ----------
        OPEN(8,FILE='res_rad5')
        REWIND 8
C --- LOOP FOR DIFFERENT TOLERANCES
        NTOLMN=2
        NTOLMX=10
        NTOLDF=4
        NRLOOP=(NTOLMX-NTOLMN)*NTOLDF+1
        TOLST=0.1D0**NTOLMN
        TOLFC=0.1D0**(1.D0/NTOLDF)
        DO 30 NTOL=1,NRLOOP
C ---------- CONSTANTS --------------
        N=40
        NN=2*N
        NCOM=N
        NSQ=N*N
        NQUATR=NSQ*NSQ
        NNCOM=NN
        AN=N
        DELTAS=1.D0/AN
C --- SET DEFAULT VALUES
        DO 12 I=1,20
        WORK(I)=0.D0
  12    IWORK(I)=0
C --------- TUNED VALUES OF WORK PARAMETERS
        WORK(3)=0.1
        WORK(4)=0.3
        WORK(5)=0.99
        WORK(6)=2.0
C --------- INITIAL VALUES -------------
        T=0.D0
        DO 1 I=1,NN
    1   Y(I)=0.D0
        TEND=5.D0
        H=1.D-3
C --- REQUIRED TOLERANCE
        RTOL=TOLST
        ATOL=RTOL
        ITOL=0
C --------- SWITCH FOR OUTPUT --------
        IOUT=0
C --- SECOND ORDER OPTION
           IJAC=0
           IWORK(9)=N
           MLJAC=N
C --- DIFFERENTIAL EQUATION IS IN EXPLICIT FORM
        IMAS=0
        CALL DTIME(TARRAY,TRESULT)
C --- CALL OF THE SUBROUTINE RADAU5
        CALL RADAU5(NN,FTIGE,T,Y,TEND,H,
     &                  RTOL,ATOL,ITOL,
     &                  FTIGE,IJAC,MLJAC,MUJAC,
     &                  FTIGE,IMAS,MLMAS,MUMAS,
     &                  SOLOUT,IOUT,
     &                  WORK,LWORK,IWORK,LIWORK,RPAR,IPAR,IDID)
        CALL DTIME(TARRAY,TRESULT)
C --- PRINT SOLUTION
        WRITE(8,9921)(Y(I),I=1,NN)
 9921   FORMAT(1X,F22.16)
        WRITE(8,*)TARRAY(1)
        WRITE (8,*) (IWORK(I),I=14,20)
        WRITE(6,*)' ***** TOL=',RTOL,'  ELAPSED TIME=',TARRAY(1),' ****'
        WRITE (6,91) (IWORK(I),I=14,20)
 91     FORMAT(' fcn=',I5,' jac=',I4,' step=',I4,
     &        ' accpt=',I4,' rejct=',I3,' dec=',I4,
     &        ' sol=',I5)
C -------- NEW TOLERANCE ---
        IF(TARRAY(1).GT.1000.)STOP
        TOLST=TOLST*TOLFC
 30     CONTINUE
        STOP
        END
C
        SUBROUTINE SOLOUT (NR,XOLD,X,Y,CONT,LRC,N,RPAR,IPAR,IRTRN)
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION Y(N),CONT(LRC)
           WRITE (6,99) X,Y(1),Y(2),NR-1
 99     FORMAT(1X,'X =',F6.2,'    Y =',2F18.7,'    NSTEP =',I4)
        RETURN
        END