C-----------------------------------------------------------------------
      SUBROUTINE SPEPS(I,M,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    SPEPS       COMPUTE UTILITY SPECTRAL FIELDS
C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 92-10-31
C
C ABSTRACT: COMPUTES CONSTANT FIELDS INDEXED IN THE SPECTRAL DOMAIN
C           IN "IBM ORDER" (ZONAL WAVENUMBER IS THE SLOWER INDEX).
C           IF L IS THE ZONAL WAVENUMBER AND N IS THE TOTAL WAVENUMBER
C           AND A IS THE EARTH RADIUS, THEN THE FIELDS RETURNED ARE:
C           (1) NORMALIZING FACTOR EPSILON=SQRT((N**2-L**2)/(4*N**2-1))
C           (2) LAPLACIAN FACTOR N*(N+1)/A**2
C           (3) ZONAL DERIVATIVE/LAPLACIAN FACTOR L/(N*(N+1))*A
C           (4) MERIDIONAL DERIVATIVE/LAPLACIAN FACTOR EPSILON/N*A
C
C PROGRAM HISTORY LOG:
C   91-10-31  MARK IREDELL
C
C USAGE:    CALL SPEPS(I,M,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP)
C
C   INPUT ARGUMENT LIST:
C     I        - INTEGER SPECTRAL DOMAIN SHAPE
C                (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL)
C     M        - INTEGER SPECTRAL TRUNCATION
C
C   OUTPUT ARGUMENT LIST:
C     EPS      - REAL ((M+1)*((I+1)*M+2)/2) SQRT((N**2-L**2)/(4*N**2-1))
C     EPSTOP   - REAL (M+1) SQRT((N**2-L**2)/(4*N**2-1)) OVER TOP
C     ENN1     - REAL ((M+1)*((I+1)*M+2)/2) N*(N+1)/A**2
C     ELONN1   - REAL ((M+1)*((I+1)*M+2)/2) L/(N*(N+1))*A
C     EON      - REAL ((M+1)*((I+1)*M+2)/2) EPSILON/N*A
C     EONTOP   - REAL (M+1) EPSILON/N*A OVER TOP
C
C ATTRIBUTES:
C   LANGUAGE: CRAY FORTRAN
C
C$$$
      REAL EPS((M+1)*((I+1)*M+2)/2),EPSTOP(M+1)
      REAL ENN1((M+1)*((I+1)*M+2)/2),ELONN1((M+1)*((I+1)*M+2)/2)
      REAL EON((M+1)*((I+1)*M+2)/2),EONTOP(M+1)
      PARAMETER(RERTH=6.3712E6,RA2=1./RERTH**2)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      DO L=0,M
        K=L*(2*M+(I-1)*(L-1))/2+L+1
        EPS(K)=0.
        ENN1(K)=RA2*L*(L+1)
        ELONN1(K)=RERTH/(L+1)
        EON(K)=0.
      ENDDO
      DO L=0,M
        DO N=L+1,I*L+M
          K=L*(2*M+(I-1)*(L-1))/2+N+1
          EPS(K)=SQRT(FLOAT(N**2-L**2)/FLOAT(4*N**2-1))
          ENN1(K)=RA2*N*(N+1)
          ELONN1(K)=RERTH*L/(N*(N+1))
          EON(K)=RERTH/N*EPS(K)
        ENDDO
      ENDDO
      DO L=0,M
        N=I*L+M+1
        EPSTOP(L+1)=SQRT(FLOAT(N**2-L**2)/FLOAT(4*N**2-1))
        EONTOP(L+1)=RERTH/N*EPSTOP(L+1)
      ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      RETURN
      END


      SUBROUTINE SHADTA(ELM,SUNPOS,KUMB,KPEN,UMBIN,UMBOUT,PENIN,
     1     PENOUT,IERPNT,IERR)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C
C  THIS ROUTINE FINDS THE TRUE ANOMALIES FOR THE ENTRANCE/EXIT TO
C  UMBRA/PENUMBRA SHADOW BY A SPACECRAFT IN ORBIT ABOUT A CENTRAL
C  BODY.
C
C  THE DATA STATEMENTS BELOW DEFINE RC, THE RADIUS OF THE CENTRAL BODY,
C  AS THAT OF THE EARTH. OTHER CENTRAL BODIES CAN BE USED BY CHANGING
C  THE VALUE OF RC.
C
C
C  VAR    DIM  TYPE  I/O  DESCRIPTION
C  ---    ---  ----  ---  -----------
C
C  ELM     6   R*8    I   THE KEPLERIAN ELEMENTS DESCRIBING THE
C                         SPACECRAFT ORBIT ABOUT THE CENTRAL BODY.
C                         ORDER IS SMA, ECC, INCL, NODE, ARGP, AND
C                         ELM(6). ELM(6) IS NOT USED, SO IT DOES NOT
C                         MATTER WHAT IS THERE. IN INERTIAL COORDINATES.
C                         UNITS ARE KM AND RADIANS.
C
C  SUNPOS  3   R*8    I   POSITION OF THE SUN IN THE SAME COORDINATE
C                         SYSTEM AS ELM. THE POSITION OF THE SUN
C                         SHOULD CORRESPOND TO THE TIME ASSOCIATED WITH
C                         ELM. IN KILOMETERS.
C
C  KUMB    1   I*4   I/O  INPUT/OUTPUT FLAG FOR UMBRA(DEEPEST SHADOW)
C                         CALCULATIONS.
C
C                     I   = NEGATIVE MEANS DO NOT DO UMBRA CALCULATIONS.
C                           IF NEGATIVE, THEN THE VARIABLE IS NOT
C                           RESET. IN THIS CASE THE CALLING PROGRAM
C                           CAN USE AN INTEGER CONSTANT IN THE CALL.
C
C                           IF ZERO OR POSITIVE, LOOK FOR UMBRA ENTRY
C                           AND EXIT TRUE ANOMALIES.
C                           IF NOT NEGATIVE, THEN KUMB RETURNS WITH
C                           ITS VALUE SET TO 0, 1, OR 2.
C
C                     O   = 0 MEANS S/C ESCAPES CENTRAL BODY, IMPACTS
C                             IT, OR AN ALGORITHM ERROR HAS OCCURRED.
C                             NO USEFUL TRUE ANOMALIES ARE RETURNED.
C
C                     O   = 1 MEANS NO SHADOW PASSAGE OCCURS.
C
C                     O   = 2 MEANS SHADOW PASSAGES OCCUR AND THE
C                             UMBRA ENTRY AND EXIT TRUE ANOMALIES ARE
C                             IN UMBIN AND UMBOUT.
C
C  KPEN    1   I*4   I/O  SAME AS FOR KUMB, EXCEPT USED FOR PENUMBRA
C                         (PARTIAL SHADOW).
C
C  UMBIN   1   R*8    O   IF KUMB=2, UMBIN IS THE TRUE ANOMALY OF THE
C                         S/C WHEN IT ENTERS UBMRA(DEEPEST SHADOW).
C                         OTHERWISE, NO USEFUL INFORMATION.
C                         RADIANS.
C
C  UMBOUT  1   R*8    O   IF KUMB=2, UMBOUT IS THE TRUE ANOMALY OF THE
C                         S/C WHEN IT LEAVES UMBRA.
C                         OTHERWISE, NO USEFUL INFORMATION.
C                         RADIANS.
C
C  PENIN   1   R*8    O   IF KPEN=2, PENIN IS THE TRUE ANOMALY OF THE
C                         S/C WHEN IT ENTERS PENUMRA(PARTIAL SHADOW).
C                         OTHERWISE, NO USEFUL INFORMATION.
C                         RADIANS.
C
C  PENOUT  1   R*8    O   IF KPEN=2, PENOUT IS THE TRUE ANOMALY OF THE
C                         S/C WHEN IT LEAVES PENUMBRA.
C                         OTHERWISE, NO USEFUL INFORMATION.
C                         RADIANS.
C
C  IERPNT  1   I*4    I   FORTRAN UNIT NUMBER FOR ERROR MESSAGE PRINTOUT
C                         IN CASE AN ALGORITHM ERROR IS SENSED. IF ZERO,
C                         NO MESSAGE IS GIVEN.
C
C  IERR    1   I*4    O   ERROR RETURN FLAG.
C                         =0, NO ERROR. =1, ERROR FOUND.
C
C***********************************************************************
C
C  WRITTEN BY RON COOK OF CSC. GIVEN TO CJP 7/77.
C  TRANSFERRED TO VAX WITH MINOR MODS. C PETRUZZO. 9/81.
C
C***********************************************************************
C
C
C THE TECHNIQUE IS PROBABLY SIMILAR TO THAT FOUND IN THE BOOK
C   METHODS OF ORBIT DETERMINATION -- P.R.ESCOBAL,1965, PAGES 155-162.
C
      DIMENSION ELM(6),SUNPOS(3),VEC(3),COEF(5),ROOTS(4),DUMROT(3,3)
      DATA ETOL/0.00150D0/
      REAL*8 RC/6378.14D0/
      REAL*8 RSUN/695500.D0/
      REAL*8 PI/ 3.141592653589793D0 /
      REAL*8 DEGRAD/ 57.29577951308232D0 /
      REAL*8 VCHECK(3),PERIGE(3)
C
      P=ELM(1)*(1.D0-ELM(2)**2)
      E = ELM(2)
      KKUMB=0
      IF(KUMB.GE.0) KKUMB=1
      KKPEN=0
      IF(KPEN.GE.0) KKPEN=1
      TA2IN = 0.D0
      TA2OUT = 0.D0
      TA1IN = 0.D0
      TA1OUT = 0.D0
      IERR=0
      INFO=1
      KOUNT = 0
      ROMIN = P/(1.D0+E)
      IF (ROMIN .GT. RC .AND. E .LT. 1.D0) GO TO 10
C     VEHICLE IMPACTS OR ESCAPES CENTRAL PLANET
      JUMB = 1
      JPEN = 1
      INFO=0
      GO TO 999
C
   10 CONTINUE
C  INITIALIZE: EXPRESS SUN IN COORDS RELATIVE TO ORBIT PLANE.
C
      AINCL=ELM(3)
      ANODE=ELM(4)
      AARGP=ELM(5)
      CW = DCOS(AARGP)
      SW = DSIN(AARGP)
      CI = DCOS(AINCL)
      SI = DSIN(AINCL)
      CO = DCOS(ANODE)
      SO = DSIN(ANODE)
C
C     FIRST, SEE IF INERTIAL Z AXIS, SUN VECTOR, AND PERIGEE VECTOR ARE
C     COPLANAR. IF SO, ALTER ARGUMENT OF PERIGEE SLIGHTLY TO MAKE THEM
C     NON-COPLANAR. EQUATIONS FAIL FOR COPLANAR CASE, HENCE MODS NEEDED.
      PERIGE(1)=CW*CO - SW*SO*CI
      PERIGE(2)=CW*SO + SW*CO*CI
C     PERIGE(3)=SW*SI
C     SEE IF THE PROJECTIONS OF THE SUN AND PERIGEE VECTORS ARE
C     COLLINEAR. IF SO, THEN VECTORS ARE COPLANAR.
      TEMP=DSQRT((PERIGE(1)**2+PERIGE(2)**2) *
     1              (SUNPOS(1)**2+SUNPOS(2)**2))
      IF(TEMP.NE.0) TEMP=(PERIGE(1)*SUNPOS(1)+PERIGE(2)*SUNPOS(2))/TEMP
      IF(DABS(TEMP).LT.(1.D0-1.D-6)) GO TO 9
      DARGP=0.0001D0/DEGRAD
      CW=DCOS(AARGP+DARGP)
      SW=DSIN(AARGP+DARGP)
    9 CONTINUE
      DUMROT(1,1) = CW*CO - SO*SW*CI
      DUMROT(1,2) =CW*SO + CO*SW*CI
      DUMROT(1,3) = SW*SI
      DUMROT(2,1) =-SW*CO-SO*CW*CI
      DUMROT(2,2) =-SW*SO + CO*CW*CI
      DUMROT(2,3) = CW*SI
      DUMROT(3,1) = SI*SO
      DUMROT(3,2) =-SI*CO
      DUMROT(3,3) = CI
      DO 8822 I=1,3
      VEC(I)=DUMROT(I,1)*SUNPOS(1)+DUMROT(I,2)*SUNPOS(2)
     1         +DUMROT(I,3)*SUNPOS(3)
 8822 VEC(I)=-VEC(I)
      CALL UNIVEC(VEC)
      CD = DSQRT(VEC(1)**2+VEC(2)**2)
      TEMP=1.D0-CD*CD
      IF(TEMP.LT.0.D0) TEMP=0.D0
      SD = DSQRT(TEMP)
      CG = VEC(1)/CD
      SG = VEC(2)/CD
      GAMA = DATAN2(VEC(2),VEC(1))
C
C     INITIALIZE FOR UMBRA
      DIS=DSQRT( SUNPOS(1)**2 + SUNPOS(2)**2 + SUNPOS(3)**2 )
      SA =(RSUN - RC)/DIS
      CA = DSQRT(1.D0-SA*SA)
      ALFA=DASIN(SA)
   11 IF (KKUMB .EQ. 0) GO TO 99
    1 IF (KOUNT . NE. 0 .AND. KKPEN.EQ.0) GO TO 99
      IF(KKUMB .NE. 0 .AND.KOUNT.EQ.1) GO TO 12
      IF(KOUNT.EQ.0) GO TO 2
C     CHANGE FOR PENUMBRA
   12 SA = (RSUN + RC)/DIS
      CA = DSQRT(1.D0-SA*SA)
      ALFA = DASIN(SA)
    2 CONTINUE
C     CHECK FOR NO POSSIBLE SHADOW
C     DETERMINE MAX DISTANCE TO SHADOW
      RSMAX = (SA*CD + SD*CA)
      IF(KOUNT .EQ. 1) RSMAX = (SD*CA - SA*CD)
      IF(RSMAX .GT. 1.D-15) GO TO 21
C     MAXIMUM PENUMBRA DISTANCE IS INFINITE
      RSMAX = 1.D20
      GO TO 22
   21 RSMAX = RC / RSMAX
      ROMIN = P/(1.D0+E)
      IF(RSMAX .GT. ROMIN) GO TO 22
C     NO SHADOW POSSIBLE
      IF (KOUNT .EQ. 0) JUMB = 2
      IF(KOUNT .EQ.1)JPEN = 2
      GO TO 99
   22 IF (E .LT. ETOL) GO TO 993
C
C     SET UP COEFFICIENTS FOR QUARTIC IN COS(SI)
C
      IF(KOUNT .EQ. 0) Q=1.0
      IF(KOUNT .EQ. 1) Q=-1.0
      A = (P*Q*SA*CD-RC*E*CG)**2+(RC*E*SG)**2+(P*CA*CD)**2
      B = 2.D0*RC*(P*Q*SA*CD-RC*E*CG)
      C = RC*RC*(1.D0-(E*SG)**2)-(P*CA)**2
      D = 2.D0*P*RC*E*SG*CA
      COEF(1) = C*C-D*D
      COEF(2) = -2.D0*B*C
      COEF(3) = 2.D0*A*C+B*B+D*D*(1.D0+CD*CD)
      COEF(4) = -2.D0*A*B
      COEF(5) = A*A - (D*CD)**2
      CALL ROOT34(COEF,4,ROOTS,NROOTS)
      NUM = NROOTS + 1
      GO TO (4,4,5,4,5),NUM
    4 CONTINUE
C     NO REAL ROOTS(ONE OR THREE NOT POSSIBLE)
      IF(KOUNT .EQ. 0) JUMB = 5
      IF(KOUNT .EQ. 1) JPEN = 5
      GO TO 99
    5 CONTINUE
C     TWO OR FOUR REAL ROOTS
C     CHECK QUADRANTS OF SOLUTIONS
      DO 51 J=1,NROOTS
      RADICL=1.D0-ROOTS(J)**2
      IF(RADICL.LT.0.D0) GO TO 7630
      SSI=DSQRT(RADICL)
      CBETA = CD*ROOTS(J)
      SBETA = DSQRT(1.D0-CBETA**2)
      RPLS = P/(1.D0+E*(ROOTS(J)*CG-SSI*SG))
      RMNS = P/(1.D0+E*(ROOTS(J)*CG+SSI*SG))
      RSHAD = RC/(SA*CBETA*Q+CA*SBETA)
      DELRP = DABS(RPLS-RSHAD)
      DELRM = DABS(RMNS - RSHAD)
      IF(DELRM .LT. DELRP) SSI=-SSI
C     REPLACE COS(SI) WITH SI
   51 ROOTS(J) = DATAN2(SSI,ROOTS(J))
 8888 CONTINUE
      IF (KOUNT .EQ. 1) GO TO 6
C
C     SELECT ANGLES FOR UMBRAL BOUNDARIES
C
      DO 52 J=1,NROOTS
      DO 52 K=J,NROOTS
      IF(DABS(ROOTS(J)).LT.DABS(ROOTS(K))) GO TO 52
      TEMP = ROOTS(J)
      ROOTS(J) = ROOTS(K)
      ROOTS(K) = TEMP
   52 CONTINUE
C     CHECK THAT SOLUTIONS ARE ON NITE SIDE OF UMBRAL TERMINATOR
      TEST = 0.5D0*PI-ALFA
      IF(DABS(ROOTS(1)).LT.TEST) GO TO 53
C     NO UMBRAL INTERSECTIONS
      JUMB = 3
      GO TO 99
   53 TA2IN = ROOTS(1)
      TA2OUT = ROOTS(2)
      IF(TA2OUT .GT. TA2IN) GO TO 54
      TA2IN = ROOTS(2)
      TA2OUT = ROOTS(1)
   54 JUMB = 4
      GO TO 99
C     SELECT ANGLES FOR PENUMBRAL BOUNDARIES
    6 DO 61 J=1,NROOTS
      DO 61 K=J,NROOTS
      IF (DABS(ROOTS(J)).LT.DABS(ROOTS(K))) GO TO 61
      TEMP = ROOTS(J)
      ROOTS(J) = ROOTS(K)
      ROOTS(K) = TEMP
   61 CONTINUE
C     CHECK TO MAKE SURE THAT SOLUTIONS ARE ON NITE SIDE
C     OF PENUMBRAL TERMINATOR
      TEST = 0.5D0*PI+ALFA
      IF(DABS(ROOTS(1)).LT.TEST) GO TO 62
C     NO PENUMBRAL INTERSECTIONS
      JPEN = 3
      GO TO 99
   62 TA1IN = ROOTS(1)
      TA1OUT = ROOTS(2)
      IF(TA1IN.LT.TA1OUT) GO TO 63
      TA1IN = ROOTS(2)
      TA1OUT = ROOTS(1)
   63 JPEN = 4
   99 KOUNT = KOUNT + 1
      IF(JUMB .NE. 4 .OR. KOUNT .NE. 1) GO TO 991
      TA2IN = TA2IN + GAMA
      TA2OUT = TA2OUT + GAMA
  991 IF (JPEN.NE.4.OR.KOUNT.NE.2) GO TO 992
      TA1IN = TA1IN + GAMA
      TA1OUT = TA1OUT + GAMA
  992 IF(KOUNT .EQ. 2) GO TO 999
      IF(KOUNT .EQ. 1 .AND. KKPEN .NE. 0) GO TO 1
      GO TO 999
C     APPROXIMATE SOLUTION FOR NEAR-CIRCULAR ORBITS
  993 CBETA = RC*SA/ROMIN
      SBETA = CA*DSQRT(1.D0-(RC/ROMIN)**2)
      IF (KOUNT .NE. 0) GO TO 994
      CBETA = CBETA +SBETA
C     UMBRA
      SI = DACOS(CBETA/CD)
      TA2IN = -SI
      TA2OUT = SI
      JUMB = 4
      GO TO 99
  994 CBETA = SBETA - CBETA
C     PENUMBRA
      SI = DACOS(CBETA/CD)
      TA1IN = -SI
      TA1OUT = SI
      JPEN = 4
      GO TO 99
C
 7630 CONTINUE
      IERR=1
      INFO=0
      IF(IERPNT.NE.0) WRITE(IERPNT,7632)
 7632 FORMAT(' SHADTA. SHADOW ALGORITHM ERROR.')
C
C
  999 CONTINUE
C
C     NOW SET UP UMBRA/PENUMBRA RETURN FLAGS.
C
C     JUMB/JPEN FLAGS HAVE BEEN DEFINED AS FOLLOWS ----
C
C     JUMB  UBMRA(DEEP SHADOW) FLAG.
C     JPEN  PENUMBRA(PARTIAL SHADOW) FLAG.
C
C     JUMB/JPEN ASSIGNMENTS HAVE BEEN --
C     =1  S/C IMPACTS OR ESCAPES PLANET. NO SHADOW
C         INFO RETURNED.
C     =2  NO SHADOW. S/C     DOES NOT ENTER SHADOW.
C     =3  NO REAL SOLUTIONS ON NIGHT SIDE OF
C         TERMINATOR. EFFECTIVELY, NO SHADOW
C         PASSAGE OCCURS.
C     =4  ENTRY AND EXIT TRUE ANOMALIES FOUND.
C         SHADOW OCCURS.
C     =5  NO REAL SOLUTIONS. EFFECTIVELY, NO SHADOW
C         PASSAGE OCCURS.
C
C     DO PENUMBRA RETURN FLAG.
      IF(KPEN.LT.0) GO TO 800
      PENIN=999.D0/DEGRAD
      PENOUT=PENIN
      IF(INFO.NE.0) GO TO 710
C     ERROR, ESCAPE, OR IMPACT. NO INFO.
      KPEN=0
      GO TO 800
  710 CONTINUE
      KPEN=1
      IF(JPEN.EQ.4) KPEN=2
      IF(KPEN.NE.2) GO TO 800
      PENIN=TA1IN
      PENOUT=TA1OUT
C
  800 CONTINUE
C     DO UMBRA RETURN FLAG.
      IF(KUMB.LT.0) GO TO 900
      UMBIN=999.D0/DEGRAD
      UMBOUT=UMBIN
      IF(INFO.NE.0) GO TO 810
C     ERROR, ESCAPE, OR IMPACT. NO INFO.
      KUMB=0
      GO TO 900
  810 CONTINUE
      KUMB=1
      IF(JUMB.EQ.4) KUMB=2
      IF(KUMB.NE.2) GO TO 900
      UMBIN=TA2IN
      UMBOUT=TA2OUT
C
  900 CONTINUE
      RETURN
      END


	SUBROUTINE MR_MHGT  ( nlev, ipt, stndat, sclhgt, iret )
C************************************************************************
C* MR_MHGT								*
C*									*
C* This subroutine computes the moist height for all levels in a	*
C* sounding.  The mandatory heights are replaced by the computed	*
C* heights.								*
C*									*
C* MR_MHGT  ( NLEV, IPT, STNDAT, SCLHGT, IRET )				*
C*									*
C* Input parameters:							*
C*	NLEV		INTEGER		Number of levels		*
C*	IPT    ( NLEV )	INTEGER		Pointers to ordered data	*
C*									*
C* Input and output parameters:						*
C*	STNDAT (6,NLEV)	REAL		Station data			*
C*									*
C* Output parameters:							*
C*	SCLHGT ( NLEV )	REAL		Scale heights			*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 9/86						*
C* M. desJardins/GSFC	 4/89	Account for missing data		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C
	REAL		stndat (6,*), sclhgt (*)
	INTEGER		ipt (*)
C
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
C
C*	Find first level with pressure, temperature and height.
C
	ilev = 1
	DO WHILE  ( ( ilev .lt. nlev ) .and.
     +		    ( ( ERMISS ( stndat (1, ipt (ilev)) ) ) .or.
     +		      ( ERMISS ( stndat (2, ipt (ilev)) ) ) .or.
     +		      ( ERMISS ( stndat (6, ipt (ilev)) ) ) ) )
	    ilev = ilev + 1
	END DO
C
C*	Get the bottom level.
C
	IF  ( ilev .lt. nlev )  THEN
	    pb  = stndat ( 1, ipt (ilev) )
	    tb  = stndat ( 2, ipt (ilev) )
	    tdb = stndat ( 3, ipt (ilev) )
	    hb  = stndat ( 4, ipt (ilev) )
	END IF
C
C*	Replace the height with the moist hydrostatic height at each
C*	level.
C
	DO  i = ilev + 1, nlev
	    tt  = stndat ( 2, ipt (i) )
	    tdt = stndat ( 3, ipt (i) )
	    pt  = stndat ( 1, ipt (i) )
	    scale  = PR_SCLH ( tb, tt, tdb, tdt, pb, pt )
	    IF ( .not. ERMISS ( scale ) )  THEN
		sclhgt ( ipt (i) ) = scale
		zzz = PR_MHGT ( hb, pb, pt, scale )
		IF  ( .not. ERMISS ( zzz ) )  THEN
		    stndat ( 6, ipt (ilev) ) = zzz
		    pb  = pt
		    tb  = tt
		    tdb = tdt
		    hb  = zzz
		END IF
	    END IF
	END DO
C*
	RETURN
	END


module derived_parameters
    use input
    use global_variables
    implicit none
    contains

	!!!!!!!!!!!!!!!!!!!!!!!!!
	!!!!!!!!!!!!!!!!!!!!!!!!!

    subroutine derived_param()
        implicit none
        integer :: i
        call read_inputfile()
        ! gas derived parameters
        lm = lm_ref*(temp/298)*(101325/p)*(1+(S_ref/298))/(1+(S_ref/temp)) ! mean free path (m)
        mu = mu_g_ref*((298+S_ref)/(temp+S_ref))*((temp/298)**(1.5)) ! viscosity (pa.s)

        m1 = Mw_p/NA ! molecular mass
        vm = m1/rho_p ! molecular volume
    end subroutine derived_param

	!!!!!!!!!!!!!!!!!!!!!!!!!
	!!!!!!!!!!!!!!!!!!!!!!!!!

    double precision function beta(v1,v2)
		implicit none
        double precision, intent(in) :: v1, v2
		double precision :: dc1, dc2, Kn1, Kn2, D1, D2, c1, c2, l1, l2, g1, g2
		call read_inputfile()

        dc1 = (6*v1/PI)**(1.0/3)
        dc2 = (6*v2/PI)**(1.0/3)
        Kn1 = 2*lm_ref/dc1
		Kn2 = 2*lm_ref/dc2

        D1 = (KB*Temp/(3*PI*mu_g_ref*dc1))*((5+4*Kn1+6*(Kn1**2)+18*(Kn1**3))/(5-Kn1+(8+PI)*(Kn1**2)))
        D2 = (KB*Temp/(3*PI*mu_g_ref*dc2))*((5+4*Kn2+6*(Kn2**2)+18*(Kn2**3))/(5-Kn2+(8+PI)*(Kn2**2)))
		c1 = ((8*KB*Temp)/(PI*rho_p*v1))**(0.5)
        c2 = ((8*KB*Temp)/(PI*rho_p*v2))**(0.5)

		l1 = 8*D1/(PI*c1)
        l2 = 8*D2/(PI*c2)

		g1 = (1/(3*dc1*l1))*(((dc1+l1)**3) +((dc1*dc1+l1*l1)**(3/2))) - dc1
        g2 = (1/(3*dc2*l2))*(((dc2+l2)**3) +((dc2*dc2+l2*l2)**(3/2))) - dc2

		beta = 2*PI*(D1+D2)*(dc1+dc2)*((((dc1+dc2)/(dc1+dc2 + 2*((g1**2 + g2**2)**(0.5)))) + (8*(D1+D2)/((((c1**2 + c2**2)**(0.5)))*(dc1+dc2))))**(-1))
    end function beta

	!!!!!!!!!!!!!!!!!!!!!!!!!
	!!!!!!!!!!!!!!!!!!!!!!!!!

	function fractn(N_modes,vk) ! COAGULATION- REDISTRIBUTION OF PARTICLE BETWEEN BINS
		implicit none
        integer, intent(in) :: N_modes
		double precision, intent(in) :: vk(N_modes)
		double precision :: fractn(N_modes,N_modes,N_modes)
		double precision :: v_new(N_modes,N_modes), sum(N_modes,N_modes), L, R
		integer :: i, j, k, flag
		! v_new(i,j) gives the the new volume of particle when particles in mode i and j collide
		! sum(i,j) gives the mode whose volume is least smaller than v(i) + v(j)
		! L is a dummy variable

		sum = 0
		do i = 1, N_modes
			do j = 1, N_modes
				v_new(i,j) = vk(i) + vk(j)
				do k = 1, N_modes
					IF (vk(k) < v_new(i,j)) THEN
						flag = 1
					ELSE
						flag = 0
					END IF
					sum(i,j) = sum(i,j) + flag
				end do
				! Now, sum(i,j) = mode # whose volume is least smaller than v(i) + v(j)
			end do
        end do

		fractn = 0
		do i = 1, N_modes
			do j = 1, N_modes
				L = sum(i,j)
				IF (L == N_modes) THEN
					fractn(i,j,L)=1
				ELSE
					R = vk(L+1)/vk(L)
					fractn(i,j,L)=(R*vk(L)-v_new(i,j))/((R-1)*vk(L))
					fractn(i,j,L+1)= (v_new(i,j)-vk(L))/((R-1)*vk(L))
				END IF
			end do
		end do
    end function fractn

	!!!!!!!!!!!!!!!!!!!!!!!!!
	!!!!!!!!!!!!!!!!!!!!!!!!!
end module derived_parameters


MODULE solfrac_mod
  USE par_kind
  IMPLICIT NONE
  REAL(KIND = wp), PRIVATE, PARAMETER, DIMENSION(9) :: pp_wgt = (/0.2370, 0.36, 0.1790, 0.087, 0.08, 0.025, 0.025, 0.007, 0.0004/)
  REAL(KIND = wp), PRIVATE, PARAMETER, DIMENSION(9) :: pp_len = (/34.84, 2.266, 0.0315, 0.0055, 8.32E-4, 1.26E-4, 3.13E-4, 7.82E-4, 1.44E-5/)
  PUBLIC :: solfrac
  CONTAINS
  REAL(KIND = dp) FUNCTION solfrac(ptop, pbottom)
    REAL(KIND = wp), INTENT(IN) :: ptop, pbottom
    INTEGER :: jt
    !$ACC KERNELS
    solfrac = 0._wp
    DO jt = 1, 9
      solfrac = solfrac + pp_wgt(jt) * (EXP(- ptop / pp_len(jt)) - EXP(- pbottom / pp_len(jt)))
    END DO
    !$ACC END KERNELS
  END FUNCTION
END MODULE solfrac_mod


      subroutine runC_iiiii(j,i1,i2,i3,i4,i5,DetGr,Xtwiddle0,
     . Gtwiddle,Shat6,N0)
      implicit none
C---Fixes Ciiiii according to extension of Denner-Dittmaier
c---knowing C00iiii with a correction of order Delta*Diiiiii
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,j,i1,i2,i3,i4,i5,n,np
      parameter(np=2)
      double precision DetGr,Xtwiddle0(np),Gtwiddle(np,np)
      double complex Shat6(np,z5max,-2:0),Shat6s(np,z5max,-2:0)

      do ep=-2,0
      do n=1,np
      Shat6s(n,z5(i1,i2,i3,i4,i5),ep)=Shat6(n,z5(i1,i2,i3,i4,i5),ep)
     .   -2d0*(delta(n,i1)*Cv(N0+czziiii(z4(i2,i3,i4,i5)),ep)
     .        +delta(n,i2)*Cv(N0+czziiii(z4(i1,i3,i4,i5)),ep)
     .        +delta(n,i3)*Cv(N0+czziiii(z4(i1,i2,i4,i5)),ep)
     .        +delta(n,i4)*Cv(N0+czziiii(z4(i1,i2,i3,i5)),ep)
     .        +delta(n,i5)*Cv(N0+czziiii(z4(i1,i2,i3,i4)),ep))
      enddo

      Cv(ciiiii(z5(i1,i2,i3,i4,i5))+N0,ep)=-(
     . +Gtwiddle(j,1)*Shat6s(1,z5(i1,i2,i3,i4,i5),ep)
     . +Gtwiddle(j,2)*Shat6s(2,z5(i1,i2,i3,i4,i5),ep)
     . -DetGr*Cv(ciiiiii(z6(j,i1,i2,i3,i4,i5))+N0,ep))
     . /Xtwiddle0(j)

c      write(6,*) 'Ciiiii ',i1,i2,i3,i4,i5,ep,
c     . +Gtwiddle(j,1)*Shat6s(1,z5(i1,i2,i3,i4,i5),ep)/Xtwiddle0(j)
c      write(6,*) 'Ciiiii ',i1,i2,i3,i4,i5,ep,
c     . +Gtwiddle(j,2)*Shat6s(2,z5(i1,i2,i3,i4,i5),ep)/Xtwiddle0(j)
c      write(6,*) 'Ciiiii ',i1,i2,i3,i4,i5,ep,
c     . -DetGr*Cv(ciiiiii(z6(j,i1,i2,i3,i4,i5))+N0,ep)/Xtwiddle0(j)

      enddo

      return
      end


c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
c $Rev: 55 $ $Date: 2014-12-31 12:16:59 -0500 (Wed, 31 Dec 2014) $
c FORTRAN 77
c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      REAL FUNCTION BDREF(MU, MUP, DPHI,
     &                     BRDF_TYPE, BRDF_ARG)

c     Supplies surface bi-directional reflectivity.
c
c     NOTE 1: Bidirectional reflectivity in DISORT is defined
c             by Eq. 39 in STWL.
c     NOTE 2: Both MU and MU0 (cosines of reflection and incidence
c             angles) are positive.
c
c  INPUT:
c
c    MU     : Cosine of angle of reflection (positive)
c
c    MUP    : Cosine of angle of incidence (positive)
c
c    DPHI   : Difference of azimuth angles of incidence and reflection
c                (radians)
c
c  LOCAL VARIABLES:
c
c    IREF   : bidirectional reflectance options
c             1 - Hapke's BDR model
c             2 - Cox-Munk BDR model
c             3 - RPV BDR model
c             4 - Ross-Li BDR model
c
c    B0     : empirical factor to account for the finite size of
c             particles in Hapke's BDR model
c
c    B      : term that accounts for the opposition effect
c             (retroreflectance, hot spot) in Hapke's BDR model
c
c    CTHETA : cosine of phase angle in Hapke's BDR model
c
c    GAMMA  : albedo factor in Hapke's BDR model
c
c    H0     : H( mu0 ) in Hapke's BDR model
c
c    H      : H( mu ) in Hapke's BDR model
c
c    HH     : angular width parameter of opposition effect in Hapke's
c             BDR model
c
c    P      : scattering phase function in Hapke's BDR model
c
c    THETA  : phase angle (radians); the angle between incidence and
c             reflection directions in Hapke's BDR model
c
c    W      : single scattering albedo in Hapke's BDR model
c
c
c   Called by- DREF, SURFAC
c +-------------------------------------------------------------------+
c     .. Scalar Arguments ..
      REAL      DPHI, MU, MUP, BRDF_ARG(4)
      INTEGER   BRDF_TYPE
c     ..
c     .. Local Scalars ..
      INTEGER   IREF
      REAL      B0, H0, HH, W
      REAL      PWS, REFRAC_INDEX, BDREF_F
      REAL      PI
      REAL      RHO0, KAPPA, G
      REAL      K_ISO, K_VOL, K_GEO, ALPHA0
      LOGICAL   DO_SHADOW
c     ..
c     .. External Subroutines ..
      EXTERNAL  ERRMSG
c     ..
c     .. Intrinsic Functions ..
      INTRINSIC COS, SQRT
c     ..

      PI   = 2.*ASIN(1.)

      IREF = BRDF_TYPE

c     ** 1. Hapke BRDF
      IF ( IREF.EQ.1 ) THEN

c       ** Hapke's BRDF model (times Pi/Mu0) (Hapke, B., Theory of reflectance
c       ** and emittance spectroscopy, Cambridge University Press, 1993, Eq.
c       ** 8.89 on page 233. Parameters are from Fig. 8.15 on page 231, expect
c       ** for w.)

        B0 = BRDF_ARG(1) !1.0
        HH = BRDF_ARG(2) !0.06
        W  = BRDF_ARG(3) !0.6

        CALL BRDF_HAPKE(MUP, MU, DPHI,
     &                  B0, HH, W, PI,
     &                  BDREF)

c     ** 2. Cox-Munk BRDF
      ELSEIF(IREF.EQ.2) THEN

c        PRINT *, "Calling oceabrdf"

        PWS          =  BRDF_ARG(1)
        REFRAC_INDEX =  BRDF_ARG(2)

        IF(BRDF_ARG(3) .EQ. 1) THEN
          DO_SHADOW = .TRUE.
        ELSEIF(BRDF_ARG(3) .EQ. 0) THEN
          DO_SHADOW = .FALSE.
        ELSE
          PRINT *, "ERROR SHADOW ARGUMENTS"
        ENDIF

        CALL OCEABRDF2(DO_SHADOW,
     &                 REFRAC_INDEX, PWS,
     &                 MUP, MU, DPHI,
     &                 BDREF_F)

        BDREF = BDREF_F

c     ** 3. RPV BRDF
      ELSEIF(IREF .EQ. 3) THEN

        RHO0  =  BRDF_ARG(1) !0.027
        KAPPA =  BRDF_ARG(2) !0.647
        G     =  BRDF_ARG(3) !-0.169   !asymmetry factor for HG
        H0    =  BRDF_ARG(4) !0.100

        CALL BRDF_RPV(MUP, MU, DPHI,
     &                RHO0, KAPPA, G, H0,
     &                BDREF_F)

        BDREF = BDREF_F

c     ** 4. Ross-Li BRDF
      ELSEIF(IREF .EQ. 4) THEN

        K_ISO  = BRDF_ARG(1)   !0.200
        K_VOL  = BRDF_ARG(2)   !0.020
        K_GEO  = BRDF_ARG(3)   !0.300
        ALPHA0 = 1.5*pi/180.

        CALL BRDF_ROSSLI(MUP, MU, DPHI,
     &                   K_ISO, K_VOL, K_GEO,
     &                   ALPHA0,
     &                   BDREF_F)

        BDREF = BDREF_F

        IF(BDREF .LT. 0.00) THEN
          BDREF = 0.00
        ENDIF

      ELSE

        CALL ERRMSG( 'BDREF--Need to supply surface BDRF model',
     &                 .TRUE.)

      ENDIF

      RETURN
      END FUNCTION
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

c +--------------------------------------------------------------------
      SUBROUTINE BRDF_HAPKE ( MUP, MU, DPHI,
     &                        B0, HH, W, PI,
     &                        BRDF )

c +--------------------------------------------------------------------
c Hapke "Theory of Reflectance and Emittance Spectroscopy" Chapter 10, Page 262
c Eq. (10.2).
c Version 3 fix: definition of phase angle / scattering angle see DISORT3
c paper Eqs. (25-26).
c +--------------------------------------------------------------------
      IMPLICIT NONE
      REAL MUP, MU, DPHI
      REAL B0, HH, W, PI
      REAL BRDF
      REAL CALPHA, ALPHA, P, B, H0, GAMMA, H

      CALPHA = MU * MUP - (1.-MU**2)**.5 * (1.-MUP**2)**.5
     &         * COS( DPHI )

      ALPHA = ACOS( CALPHA )

      P     = 1. + 0.5 * CALPHA

      B     = B0 * HH / ( HH + TAN( ALPHA/2.) )

      GAMMA = SQRT( 1. - W )
      H0   = ( 1. + 2.*MUP ) / ( 1. + 2.*MUP * GAMMA )
      H    = ( 1. + 2.*MU ) / ( 1. + 2.*MU * GAMMA )

c     ** Version 3: add factor PI
      BRDF = W / (4.*PI) / (MU+MUP) * ( (1.+B)* P + H0 * H - 1.0 )
c     BRDF = W / 4. / (MU+MUP) * ( (1.+B)* P + H0 * H - 1.0 )

      END
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

c +--------------------------------------------------------------------
      SUBROUTINE BRDF_RPV(MU_I, MU_R, DPHI,
     &                    RHO0, KAPPA, G_HG, H0,
     &                    BRDF)

c +--------------------------------------------------------------------
c DISORT Version 3: RPV BRDF
c   Input:
c
c   MU_I:  absolute cosine of incident polar angle (positive)
c   MU_R:  absolute cosine of reflected polar angle (positive)
c   DPHI:  relative azimuth to incident vector; (pi - dphi), sun-view relative
c          azimuth sun located at phi = 180, while incident solar beam located
c          at phi = 0
c   RHO0:  RPV BRDF parameter, control reflectance
c   KAPPA: PRV BRDF parameter, control anisotropy
c   G:     RPV BRDF parameter, H-G asymmetry factor
c   H0:    RPV BRDF parameter, control hot spot (back scattering direction)
c
c   Output:
c
c   BRDF:  RPV BRDF
c +--------------------------------------------------------------------
      IMPLICIT NONE
      REAL MU_I, MU_R, DPHI
      REAL RHO0, KAPPA, G_HG, H0
      REAL BRDF
      REAL PI
      REAL COS_ALPHA
      REAL SIN_I, SIN_R, TAN_I, TAN_R
      REAL G_SQ, G, F

      PI    = 2.*ASIN(1.)

      SIN_I = SQRT(1. - MU_I*MU_I)
      SIN_R = SQRT(1. - MU_R*MU_R)
      TAN_I = SIN_I/MU_I
      TAN_R = SIN_R/MU_R

      COS_ALPHA = MU_I*MU_R - SIN_I*SIN_R
     & *COS(DPHI)

      G_SQ = TAN_I*TAN_I + TAN_R*TAN_R
     &    + 2.*TAN_I*TAN_R*COS(DPHI)

c     ** hot spot
      G = SQRT(G_SQ)

c     ** HG phase function
      F = (1. - G_HG*G_HG)/
     &     (1+G_HG*G_HG+2.*G_HG*COS_ALPHA)**1.5

c     ** BRDF semiempirical function
      BRDF = RHO0
     &      * (MU_I*MU_R*(MU_I+MU_R))**(KAPPA-1.)
     &      * F
     &      * (1. + ((1.-H0)/(1.+G)))

      END
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

c +--------------------------------------------------------------------
      SUBROUTINE BRDF_ROSSLI(MU_I, MU_R, DPHI,
     &                       K_ISO, K_VOL, K_GEO,
     &                       ALPHA0,
     &                       BRDF)

c +--------------------------------------------------------------------
c Version 3: Ross-Li BRDF
c   Input:
c
c   MU_I:    absolute cosine of incident polar angle (positive)
c   MU_R:    absolute cosine of reflected polar angle (positive)
c   DPHI:  relative azimuth to incident vector; (pi - dphi), sun-view relative
c          azimuth sun located at phi = 180, while incident solar beam located
c          at phi = 0
c   K_ISO:   BRDF parameter, isotropic scattering kernel
c   K_VOL:   BRDF parameter, volume scattering kernel
c   K_GEO:   BRDF parameter, geometry scattering kernel
c   ALPHA0:  BRDF parameter, control hot spot (back scattering direction)
c
c   Output:
c   BRDF:  Ross-Li BRDF
c
c +--------------------------------------------------------------------
      IMPLICIT NONE
      REAL MU_I, MU_R, DPHI
      REAL F_GEO, F_VOL
      REAL K_ISO, K_GEO, K_VOL
      REAL RATIO_HB, RATIO_BR
      REAL BRDF
      REAL PI
      REAL COS_ALPHA, SIN_ALPHA
      REAL COS_ALPHA1
      REAL ALPHA
      REAL SIN_I, SIN_R, TAN_I, TAN_R
      REAL SIN_I1, SIN_R1, COS_I1, COS_R1, TAN_I1, TAN_R1
      REAL G_SQ, COS_T, T
      REAL C, ALPHA0
c +--------------------------------------------------------------------

c      PRINT *, MU_I, MU_R, DPHI,
c     &        K_ISO, K_GEO, K_VOL,
c     &        THETA0
c      PRINT *,

      RATIO_HB = 2.
      RATIO_BR = 1.
      PI       = 2.*ASIN(1.)

      SIN_I = SQRT(1. - MU_I*MU_I)
      SIN_R = SQRT(1. - MU_R*MU_R)
      TAN_I = SIN_I/MU_I
      TAN_R = SIN_R/MU_R

      COS_ALPHA = MU_I*MU_R - SIN_I*SIN_R
     & *COS(DPHI)
      SIN_ALPHA = SQRT(1. - COS_ALPHA*COS_ALPHA)
      ALPHA = ACOS(COS_ALPHA)

c     ** Compute KERNEL RossThick
      C     = 1. + 1./(1.+ALPHA/ALPHA0)
      F_VOL = 4./(3.*PI) * (1./(MU_I+MU_R))
     &       * ((PI/2. - ALPHA)*COS_ALPHA+SIN_ALPHA)*C - 1./3.

c      K1 = ((PI/2. - ALPHA)*COS_ALPHA + SIN_ALPHA)
c     &       /(MU_I + MU_R) - PI/4.

c     ** Compute KERNEL LSR
      TAN_I1 = RATIO_BR * TAN_I
      TAN_R1 = RATIO_BR * TAN_R
      SIN_I1 = TAN_I1/SQRT(1.+ TAN_I1*TAN_I1)
      SIN_R1 = TAN_R1/SQRT(1.+ TAN_R1*TAN_R1)
      COS_I1 = 1./SQRT(1.+ TAN_I1*TAN_I1)
      COS_R1 = 1./SQRT(1.+ TAN_R1*TAN_R1)

      COS_ALPHA1 = COS_I1*COS_R1 - SIN_I1*SIN_R1
     &            *COS(DPHI)

      G_SQ = TAN_I1*TAN_I1 + TAN_R1*TAN_R1
     &      + 2.*TAN_I1*TAN_R1*COS(DPHI)

c      M = 1./COS_I1 + 1./COS_R1

      COS_T = RATIO_HB *(COS_I1*COS_R1)/(COS_I1+COS_R1)
     &       *SQRT(G_SQ + (TAN_I1*TAN_R1*SIN(DPHI))**2)

      IF(COS_T .LE. 1. .AND. COS_T .GE. -1.) THEN
        T = ACOS(COS_T)
      ELSE
        T = 0.
      ENDIF

      F_GEO = (COS_I1+COS_R1)/(PI*COS_I1*COS_R1)*(T-SIN(T)*COS(T)-PI)
     &       + (1.+ COS_ALPHA1)/(2.*COS_I1*COS_R1)

c     Compute BRDF

c      PRINT *, RATIO_HB, D_SQ,
c     &    TAN_I1*TAN_R1*SIN(DPHI),
c     &    M, COS_T

c      BRDF = K1
      BRDF = K_ISO + K_GEO*F_GEO + K_VOL*F_VOL

      END
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

c +--------------------------------------------------------------------
      SUBROUTINE OCEABRDF2
     &       ( DO_SHADOW,
     &         REFRAC_INDEX, WS,
     &         MU_I, MU_R, DPHI,
     &         BRDF)

c +--------------------------------------------------------------------
c Version 3: 1D Gaussian Rough Ocean BRDF
c   Input:
c
c   mu_i:         absolute cosine of incident polar angle (positive)
c   mu_r:         absolute cosine of reflected polar angle (positive)
c   dphi:         relative azimuth (radians)
c   do_shadow:    BRDF parameter, open/close shadow effect
c   refrac_index: BRDF parameter, refractive index of boundary media (water)
c   ws:           BRDF parameter, wind speed (m/s)
c
c   Output:
c
c   brdf:         1D Gaussian Rough Ocean BRDF
c
c +--------------------------------------------------------------------
      LOGICAL  DO_SHADOW
      REAL     REFRAC_INDEX, WS
      REAL     SIN_I, SIN_R, MU_I, MU_R, DPHI, BRDF
      REAL     COS_THETA, SIGMA_SQ, MU_N_SQ, P
      REAL     N_I, N_T, COS_LI, COS_LT, SIN_LI, SIN_LT
      REAL     R_S, R_P, R
      REAL     SHADOW
      REAL     PI

      PI = 2.*ASIN(1.)

c     ** Cox Munk slope distribution
      SIN_I = SQRT(1. - MU_I*MU_I)
      SIN_R = SQRT(1. - MU_R*MU_R)

      COS_THETA = -MU_I*MU_R + SIN_I*SIN_R*COS(DPHI)
      MU_N_SQ   = (MU_I + MU_R)*(MU_I + MU_R)/(2.*(1.-COS_THETA))

      SIGMA_SQ  = 0.003 + 0.00512*WS

      P = 1./(PI*SIGMA_SQ) * EXP( -(1-MU_N_SQ)/(SIGMA_SQ*MU_N_SQ) )

c     ** Fresnel reflectance

      N_I = 1.0
      N_T = REFRAC_INDEX

      SIN_LI = SQRT( 1.-0.5*(1.-COS_THETA) )
      COS_LI = SQRT( 0.5*(1.-COS_THETA) )
      SIN_LT = N_I*SIN_LI/N_T
      COS_LT = SQRT(1. - SIN_LT*SIN_LT)

      R_S = (N_I*COS_LI-N_T*COS_LT)/(N_I*COS_LI+N_T*COS_LT)
      R_P = (N_T*COS_LI-N_I*COS_LT)/(N_I*COS_LT+N_T*COS_LI)

      R = 0.5*(R_S*R_S + R_P*R_P)

c     ** Rough surface BRDF
      BRDF = (P*R)/(4.*MU_I*MU_R*MU_N_SQ*MU_N_SQ)

c     Shadowing effect (see Tsang, Kong, Shin, Theory of Microwave Remote
c     Sensing, Wiley-Interscience, 1985)
      IF(DO_SHADOW) THEN
        SHADOW = 1./( SHADOW_ETA(MU_I, SIGMA_SQ, PI)
     &          + SHADOW_ETA(MU_R, SIGMA_SQ, PI) + 1. )
        BRDF = BRDF*SHADOW
      ENDIF

      END
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

c +--------------------------------------------------------------------
      REAL FUNCTION SHADOW_ETA(COS_THETA, SIGMA_SQ, PI)
c +--------------------------------------------------------------------
c Version 3: shadow effect function
c            called by OCEABRDF2
c   Input:
c
c   COS_THETA     absolute cosine of incident/reflected polar angle (positive)
c   SIGMA_SQ      slope variance
c   PI            3.141592653... constant
c
c   Output:
c
c   SHADOW_ETA:   shadow function
c +--------------------------------------------------------------------
      REAL COS_THETA, SIN_THETA
      REAL MU, SIGMA_SQ, PI
      REAL TERM1, TERM2

      SIN_THETA = SQRT(1.-COS_THETA*COS_THETA)
      MU = COS_THETA/SIN_THETA

      TERM1 = SQRT(SIGMA_SQ/PI)/MU*EXP( -MU*MU/(SIGMA_SQ) )
      TERM2 = ERFC( MU/SQRT(SIGMA_SQ) )

      SHADOW_ETA = 0.5*(TERM1 - TERM2)

      END
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -


      DOUBLE PRECISION FUNCTION bfrac(a,b,x,y,lambda,eps)
C-----------------------------------------------------------------------
C     CONTINUED FRACTION EXPANSION FOR IX(A,B) WHEN A,B .GT. 1.
C     IT IS ASSUMED THAT  LAMBDA = (A + B)*Y - B.
C-----------------------------------------------------------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION a,b,eps,lambda,x,y
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION alpha,an,anp1,beta,bn,bnp1,c,c0,c1,e,n,p,r,r0,s,
     +                 t,w,yp1
C     ..
C     .. External Functions ..
      DOUBLE PRECISION brcomp
      EXTERNAL brcomp
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC abs
C     ..
C     .. Executable Statements ..
C--------------------
      bfrac = brcomp(a,b,x,y)
      IF (bfrac.EQ.0.0D0) RETURN
C
      c = 1.0D0 + lambda
      c0 = b/a
      c1 = 1.0D0 + 1.0D0/a
      yp1 = y + 1.0D0
C
      n = 0.0D0
      p = 1.0D0
      s = a + 1.0D0
      an = 0.0D0
      bn = 1.0D0
      anp1 = 1.0D0
      bnp1 = c/c1
      r = c1/c
C
C        CONTINUED FRACTION CALCULATION
C
   10 n = n + 1.0D0
      t = n/a
      w = n* (b-n)*x
      e = a/s
      alpha = (p* (p+c0)*e*e)* (w*x)
      e = (1.0D0+t)/ (c1+t+t)
      beta = n + w/s + e* (c+n*yp1)
      p = 1.0D0 + t
      s = s + 2.0D0
C
C        UPDATE AN, BN, ANP1, AND BNP1
C
      t = alpha*an + beta*anp1
      an = anp1
      anp1 = t
      t = alpha*bn + beta*bnp1
      bn = bnp1
      bnp1 = t
C
      r0 = r
      r = anp1/bnp1
      IF (.NOT.(abs(r-r0).GT.eps*r)) GO TO 20
C
C        RESCALE AN, BN, ANP1, AND BNP1
C
      an = an/bnp1
      bn = bn/bnp1
      anp1 = r
      bnp1 = 1.0D0
      GO TO 10
C
C                 TERMINATION
C
   20 bfrac = bfrac*r
      RETURN

      END


PROGRAM ApplicationDriver

  USE KindModule, ONLY: &
    DP, Half, One, Two, &
    Pi, TwoPi, FourPi
  USE UnitsModule, ONLY: &
    Centimeter, &
    Kilometer, &
    Millisecond, &
    Gram, Erg
  USE ProgramHeaderModule, ONLY: &
    iX_B0, iX_B1, iX_E0, iX_E1
  USE ProgramInitializationModule, ONLY: &
    InitializeProgram, &
    FinalizeProgram
  USE ReferenceElementModuleX, ONLY: &
    InitializeReferenceElementX, &
    FinalizeReferenceElementX
  USE ReferenceElementModuleX_Lagrange, ONLY: &
    InitializeReferenceElementX_Lagrange, &
    FinalizeReferenceElementX_Lagrange
  USE InputOutputModuleHDF, ONLY: &
    WriteFieldsHDF
  USE GeometryComputationModule, ONLY: &
    ComputeGeometryX
  USE GravitySolutionModule_Newtonian_Poseidon, ONLY: &
    InitializeGravitySolver_Newtonian_Poseidon, &
    FinalizeGravitySolver_Newtonian_Poseidon, &
    SolveGravity_Newtonian_Poseidon
  USE FluidFieldsModule, ONLY: &
    uCF, uPF, uAF, uDF, &
    iCF_D
  USE Euler_SlopeLimiterModule_NonRelativistic_IDEAL, ONLY: &
    InitializeSlopeLimiter_Euler_NonRelativistic_IDEAL, &
    FinalizeSlopeLimiter_Euler_NonRelativistic_IDEAL, &
    ApplySlopeLimiter_Euler_NonRelativistic_IDEAL
  USE Euler_PositivityLimiterModule_NonRelativistic_IDEAL, ONLY: &
    InitializePositivityLimiter_Euler_NonRelativistic_IDEAL, &
    FinalizePositivityLimiter_Euler_NonRelativistic_IDEAL, &
    ApplyPositivityLimiter_Euler_NonRelativistic_IDEAL
  USE GeometryFieldsModule, ONLY: &
    uGF
  USE EquationOfStateModule, ONLY: &
    InitializeEquationOfState, &
    FinalizeEquationOfState
  USE InitializationModule, ONLY: &
    InitializeFields
  USE TimeSteppingModule_SSPRK, ONLY: &
    InitializeFluid_SSPRK, &
    FinalizeFluid_SSPRK, &
    UpdateFluid_SSPRK
  USE Euler_UtilitiesModule_NonRelativistic, ONLY: &
    ComputeFromConserved_Euler_NonRelativistic, &
    ComputeTimeStep_Euler_NonRelativistic
  USE Euler_dgDiscretizationModule, ONLY: &
    ComputeIncrement_Euler_DG_Explicit
  USE Euler_TallyModule_NonRelativistic, ONLY: &
    InitializeTally_Euler_NonRelativistic, &
    FinalizeTally_Euler_NonRelativistic, &
    ComputeTally_Euler_NonRelativistic

  IMPLICIT NONE

  INCLUDE 'mpif.h'

  CHARACTER(64), PARAMETER :: FileName = 'YahilHomologousCollapse_Gm_130.dat'
  REAL(DP),      PARAMETER :: Gamma           = 1.3_DP
  REAL(DP),      PARAMETER :: CollapseTime    = 150_DP * Millisecond
  REAL(DP),      PARAMETER :: CentralDensity  = 7.0d9 * Gram / Centimeter**3
  REAL(DP),      PARAMETER :: CentralPressure = 6.0d27 * Erg / Centimeter**3
  REAL(DP),      PARAMETER :: CoreRadius      = 1.0d5 * Kilometer

  LOGICAL  :: wrt
  INTEGER  :: iCycle, iCycleD
  INTEGER  :: nX(3), nNodes
  REAL(DP) :: xL(3), xR(3)
  REAL(DP) :: t, dt, t_end, dt_wrt, t_wrt, wTime

  nX     = [ 128, 1, 1 ]
  nNodes = 3
  xL     = [ 0.0d0,      0.0d0, 0.0d0 ]
  xR     = [ CoreRadius, Pi,    TwoPi ]

  CALL InitializeProgram &
         ( ProgramName_Option &
             = 'YahilLattimerCollapse', &
           nX_Option &
             = nX, &
           swX_Option &
             = [ 1, 1, 1 ], &
           bcX_Option &
             = [ 30, 3, 1 ], &
           xL_Option &
             = xL, &
           xR_Option &
             = xR, &
           zoomX_Option &
             = [ 1.071835456828339_DP, 1.0_DP, 1.0_DP ], &
           nNodes_Option &
             = nNodes, &
           CoordinateSystem_Option &
             = 'SPHERICAL', &
           ActivateUnits_Option &
             = .TRUE., &
           BasicInitialization_Option &
             = .TRUE. )

  t_end   = CollapseTime - 0.5_DP * Millisecond
  dt_wrt  = 0.1_DP * Millisecond
  iCycleD = 100

  CALL InitializeReferenceElementX

  CALL InitializeReferenceElementX_Lagrange

  CALL ComputeGeometryX &
         ( iX_B0, iX_E0, iX_B1, iX_E1, uGF )

  CALL InitializeEquationOfState &
         ( EquationOfState_Option = 'IDEAL', &
           Gamma_IDEAL_Option = Gamma )

  CALL InitializeSlopeLimiter_Euler_NonRelativistic_IDEAL &
         ( BetaTVD_Option = 1.15_DP, &
           BetaTVB_Option = 0.00_DP, &
           SlopeTolerance_Option = 1.0d-6, &
           UseSlopeLimiter_Option = .FALSE., &
           UseTroubledCellIndicator_Option = .FALSE., &
           LimiterThresholdParameter_Option = 0.12_DP )

  CALL InitializePositivityLimiter_Euler_NonRelativistic_IDEAL &
         ( Min_1_Option = 1.0d-12, &
           Min_2_Option = 1.0d-12, &
           UsePositivityLimiter_Option = .FALSE. )

  CALL InitializeFields &
         ( FileName, Gamma, CollapseTime, CentralDensity, CentralPressure )

  CALL ApplySlopeLimiter_Euler_NonRelativistic_IDEAL &
         ( iX_B0, iX_E0, iX_B1, iX_E1, uGF, uCF, uDF )

  CALL ApplyPositivityLimiter_Euler_NonRelativistic_IDEAL &
         ( iX_B0, iX_E0, iX_B1, iX_E1, uGF, uCF )

  CALL ComputeFromConserved_Euler_NonRelativistic &
         ( iX_B0, iX_E0, iX_B1, iX_E1, uGF, uCF, uPF, uAF )

  CALL InitializeGravitySolver_Newtonian_Poseidon

  CALL SolveGravity_Newtonian_Poseidon &
         ( iX_B0, iX_E0, iX_B1, iX_E1, &
           uGF(1:,iX_B1(1):,iX_B1(2):,iX_B1(3):,1:), &
           uCF(1:,iX_B1(1):,iX_B1(2):,iX_B1(3):,iCF_D) )

!  CALL ComputeGravitationalPotential &
!         ( iX_B0, iX_E0, iX_B1, iX_E1, uGF, uCF )

  CALL WriteFieldsHDF &
         ( 0.0_DP, WriteGF_Option = .TRUE., WriteFF_Option = .TRUE. )

  CALL InitializeFluid_SSPRK( nStages = 3 )

  ! --- Evolve ---

  wTime = MPI_WTIME( )

  t     = 0.0_DP
  t_wrt = dt_wrt
  wrt   = .FALSE.

  CALL InitializeTally_Euler_NonRelativistic &
         ( iX_B0, iX_E0, iX_B1, iX_E1, uGF, uCF )

  CALL ComputeTally_Euler_NonRelativistic &
       ( iX_B0, iX_E0, iX_B1, iX_E1, uGF, uCF, Time = t, &
         SetInitialValues_Option = .TRUE., Verbose_Option = .TRUE. )

  iCycle = 0
  DO WHILE ( t < t_end )

    iCycle = iCycle + 1

    CALL ComputeTimeStep_Euler_NonRelativistic &
           ( iX_B0, iX_E0, iX_B1, iX_E1, uGF, uCF, &
             CFL = 0.3_DP / ( Two * DBLE( nNodes - 1 ) + One ), &
             TimeStep = dt )

    IF( t + dt > t_end )THEN

      dt = t_end - t

    END IF

    IF( t + dt > t_wrt )THEN

      dt    = t_wrt - t
      t_wrt = t_wrt + dt_wrt
      wrt   = .TRUE.

    END IF

    IF( MOD( iCycle, iCycleD ) == 0 )THEN

      WRITE(*,'(A8,A8,I8.8,A2,A9,ES13.6E3,A1,A10,ES13.6E3)') &
          '', 'Cycle = ', iCycle, &
          '', 't [ms] = ',  t / Millisecond, &
          '', 'dt [ms] = ', dt / Millisecond

    END IF

    CALL UpdateFluid_SSPRK &
           ( t, dt, uGF, uCF, uDF, &
             ComputeIncrement_Euler_DG_Explicit, &
             SolveGravity_Newtonian_Poseidon )

    t = t + dt

    IF( wrt )THEN

      CALL ComputeFromConserved_Euler_NonRelativistic &
             ( iX_B0, iX_E0, iX_B1, iX_E1, uGF, uCF, uPF, uAF )

      CALL WriteFieldsHDF &
             ( t, WriteGF_Option = .TRUE., WriteFF_Option = .TRUE. )

      CALL ComputeTally_Euler_NonRelativistic &
             ( iX_B0, iX_E0, iX_B1, iX_E1, uGF, uCF, Time = t, &
               Verbose_Option = .TRUE. )

      wrt = .FALSE.

    END IF

  END DO

  CALL ComputeFromConserved_Euler_NonRelativistic &
         ( iX_B0, iX_E0, iX_B1, iX_E1, uGF, uCF, uPF, uAF )

  CALL WriteFieldsHDF &
         ( t, WriteGF_Option = .TRUE., WriteFF_Option = .TRUE. )

  CALL ComputeTally_Euler_NonRelativistic &
         ( iX_B0, iX_E0, iX_B1, iX_E1, uGF, uCF, Time = t, &
           Verbose_Option = .TRUE. )

  CALL FinalizeTally_Euler_NonRelativistic

  wTime = MPI_WTIME( ) - wTime

  WRITE(*,*)
  WRITE(*,'(A6,A,I8.8,A,ES12.6E2,A)') &
    '', 'Finished ', iCycle, ' Cycles in ', wTime, ' s'
  WRITE(*,*)

  ! --- Finalize ---

  CALL FinalizePositivityLimiter_Euler_NonRelativistic_IDEAL

  CALL FinalizeSlopeLimiter_Euler_NonRelativistic_IDEAL

  CALL FinalizeEquationOfState

  CALL FinalizeFluid_SSPRK

  CALL FinalizeGravitySolver_Newtonian_Poseidon

  CALL FinalizeReferenceElementX_Lagrange

  CALL FinalizeReferenceElementX

  CALL FinalizeProgram

END PROGRAM ApplicationDriver


*> \brief \b CGEMM
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE CGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
*
*       .. Scalar Arguments ..
*       COMPLEX ALPHA,BETA
*       INTEGER K,LDA,LDB,LDC,M,N
*       CHARACTER TRANSA,TRANSB
*       ..
*       .. Array Arguments ..
*       COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CGEMM  performs one of the matrix-matrix operations
*>
*>    C := alpha*op( A )*op( B ) + beta*C,
*>
*> where  op( X ) is one of
*>
*>    op( X ) = X   or   op( X ) = X**T   or   op( X ) = X**H,
*>
*> alpha and beta are scalars, and A, B and C are matrices, with op( A )
*> an m by k matrix,  op( B )  a  k by n matrix and  C an m by n matrix.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] TRANSA
*> \verbatim
*>          TRANSA is CHARACTER*1
*>           On entry, TRANSA specifies the form of op( A ) to be used in
*>           the matrix multiplication as follows:
*>
*>              TRANSA = 'N' or 'n',  op( A ) = A.
*>
*>              TRANSA = 'T' or 't',  op( A ) = A**T.
*>
*>              TRANSA = 'C' or 'c',  op( A ) = A**H.
*> \endverbatim
*>
*> \param[in] TRANSB
*> \verbatim
*>          TRANSB is CHARACTER*1
*>           On entry, TRANSB specifies the form of op( B ) to be used in
*>           the matrix multiplication as follows:
*>
*>              TRANSB = 'N' or 'n',  op( B ) = B.
*>
*>              TRANSB = 'T' or 't',  op( B ) = B**T.
*>
*>              TRANSB = 'C' or 'c',  op( B ) = B**H.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>           On entry,  M  specifies  the number  of rows  of the  matrix
*>           op( A )  and of the  matrix  C.  M  must  be at least  zero.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>           On entry,  N  specifies the number  of columns of the matrix
*>           op( B ) and the number of columns of the matrix C. N must be
*>           at least zero.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*>          K is INTEGER
*>           On entry,  K  specifies  the number of columns of the matrix
*>           op( A ) and the number of rows of the matrix op( B ). K must
*>           be at least  zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*>          ALPHA is COMPLEX
*>           On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is COMPLEX array, dimension ( LDA, ka ), where ka is
*>           k  when  TRANSA = 'N' or 'n',  and is  m  otherwise.
*>           Before entry with  TRANSA = 'N' or 'n',  the leading  m by k
*>           part of the array  A  must contain the matrix  A,  otherwise
*>           the leading  k by m  part of the array  A  must contain  the
*>           matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>           On entry, LDA specifies the first dimension of A as declared
*>           in the calling (sub) program. When  TRANSA = 'N' or 'n' then
*>           LDA must be at least  max( 1, m ), otherwise  LDA must be at
*>           least  max( 1, k ).
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*>          B is COMPLEX array, dimension ( LDB, kb ), where kb is
*>           n  when  TRANSB = 'N' or 'n',  and is  k  otherwise.
*>           Before entry with  TRANSB = 'N' or 'n',  the leading  k by n
*>           part of the array  B  must contain the matrix  B,  otherwise
*>           the leading  n by k  part of the array  B  must contain  the
*>           matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>           On entry, LDB specifies the first dimension of B as declared
*>           in the calling (sub) program. When  TRANSB = 'N' or 'n' then
*>           LDB must be at least  max( 1, k ), otherwise  LDB must be at
*>           least  max( 1, n ).
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*>          BETA is COMPLEX
*>           On entry,  BETA  specifies the scalar  beta.  When  BETA  is
*>           supplied as zero then C need not be set on input.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*>          C is COMPLEX array, dimension ( LDC, N )
*>           Before entry, the leading  m by n  part of the array  C must
*>           contain the matrix  C,  except when  beta  is zero, in which
*>           case C need not be set on entry.
*>           On exit, the array  C  is overwritten by the  m by n  matrix
*>           ( alpha*op( A )*op( B ) + beta*C ).
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*>          LDC is INTEGER
*>           On entry, LDC specifies the first dimension of C as declared
*>           in  the  calling  (sub)  program.   LDC  must  be  at  least
*>           max( 1, m ).
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex_blas_level3
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  Level 3 Blas routine.
*>
*>  -- Written on 8-February-1989.
*>     Jack Dongarra, Argonne National Laboratory.
*>     Iain Duff, AERE Harwell.
*>     Jeremy Du Croz, Numerical Algorithms Group Ltd.
*>     Sven Hammarling, Numerical Algorithms Group Ltd.
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE CGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
*
*  -- Reference BLAS level3 routine (version 3.7.0) --
*  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      COMPLEX ALPHA,BETA
      INTEGER K,LDA,LDB,LDC,M,N
      CHARACTER TRANSA,TRANSB
*     ..
*     .. Array Arguments ..
      COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
*     ..
*
*  =====================================================================
*
*     .. External Functions ..
      LOGICAL LSAME
      EXTERNAL LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC CONJG,MAX
*     ..
*     .. Local Scalars ..
      COMPLEX TEMP
      INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB
      LOGICAL CONJA,CONJB,NOTA,NOTB
*     ..
*     .. Parameters ..
      COMPLEX ONE
      PARAMETER (ONE= (1.0E+0,0.0E+0))
      COMPLEX ZERO
      PARAMETER (ZERO= (0.0E+0,0.0E+0))
*     ..
*
*     Set  NOTA  and  NOTB  as  true if  A  and  B  respectively are not
*     conjugated or transposed, set  CONJA and CONJB  as true if  A  and
*     B  respectively are to be  transposed but  not conjugated  and set
*     NROWA, NCOLA and  NROWB  as the number of rows and  columns  of  A
*     and the number of rows of  B  respectively.
*
      NOTA = LSAME(TRANSA,'N')
      NOTB = LSAME(TRANSB,'N')
      CONJA = LSAME(TRANSA,'C')
      CONJB = LSAME(TRANSB,'C')
      IF (NOTA) THEN
          NROWA = M
          NCOLA = K
      ELSE
          NROWA = K
          NCOLA = M
      END IF
      IF (NOTB) THEN
          NROWB = K
      ELSE
          NROWB = N
      END IF
*
*     Test the input parameters.
*
      INFO = 0
      IF ((.NOT.NOTA) .AND. (.NOT.CONJA) .AND.
     +    (.NOT.LSAME(TRANSA,'T'))) THEN
          INFO = 1
      ELSE IF ((.NOT.NOTB) .AND. (.NOT.CONJB) .AND.
     +         (.NOT.LSAME(TRANSB,'T'))) THEN
          INFO = 2
      ELSE IF (M.LT.0) THEN
          INFO = 3
      ELSE IF (N.LT.0) THEN
          INFO = 4
      ELSE IF (K.LT.0) THEN
          INFO = 5
      ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
          INFO = 8
      ELSE IF (LDB.LT.MAX(1,NROWB)) THEN
          INFO = 10
      ELSE IF (LDC.LT.MAX(1,M)) THEN
          INFO = 13
      END IF
      IF (INFO.NE.0) THEN
          CALL XERBLA('CGEMM ',INFO)
          RETURN
      END IF
*
*     Quick return if possible.
*
      IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
     +    (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
*
*     And when  alpha.eq.zero.
*
      IF (ALPHA.EQ.ZERO) THEN
          IF (BETA.EQ.ZERO) THEN
              DO 20 J = 1,N
                  DO 10 I = 1,M
                      C(I,J) = ZERO
   10             CONTINUE
   20         CONTINUE
          ELSE
              DO 40 J = 1,N
                  DO 30 I = 1,M
                      C(I,J) = BETA*C(I,J)
   30             CONTINUE
   40         CONTINUE
          END IF
          RETURN
      END IF
*
*     Start the operations.
*
      IF (NOTB) THEN
          IF (NOTA) THEN
*
*           Form  C := alpha*A*B + beta*C.
*
              DO 90 J = 1,N
                  IF (BETA.EQ.ZERO) THEN
                      DO 50 I = 1,M
                          C(I,J) = ZERO
   50                 CONTINUE
                  ELSE IF (BETA.NE.ONE) THEN
                      DO 60 I = 1,M
                          C(I,J) = BETA*C(I,J)
   60                 CONTINUE
                  END IF
                  DO 80 L = 1,K
                      TEMP = ALPHA*B(L,J)
                      DO 70 I = 1,M
                          C(I,J) = C(I,J) + TEMP*A(I,L)
   70                 CONTINUE
   80             CONTINUE
   90         CONTINUE
          ELSE IF (CONJA) THEN
*
*           Form  C := alpha*A**H*B + beta*C.
*
              DO 120 J = 1,N
                  DO 110 I = 1,M
                      TEMP = ZERO
                      DO 100 L = 1,K
                          TEMP = TEMP + CONJG(A(L,I))*B(L,J)
  100                 CONTINUE
                      IF (BETA.EQ.ZERO) THEN
                          C(I,J) = ALPHA*TEMP
                      ELSE
                          C(I,J) = ALPHA*TEMP + BETA*C(I,J)
                      END IF
  110             CONTINUE
  120         CONTINUE
          ELSE
*
*           Form  C := alpha*A**T*B + beta*C
*
              DO 150 J = 1,N
                  DO 140 I = 1,M
                      TEMP = ZERO
                      DO 130 L = 1,K
                          TEMP = TEMP + A(L,I)*B(L,J)
  130                 CONTINUE
                      IF (BETA.EQ.ZERO) THEN
                          C(I,J) = ALPHA*TEMP
                      ELSE
                          C(I,J) = ALPHA*TEMP + BETA*C(I,J)
                      END IF
  140             CONTINUE
  150         CONTINUE
          END IF
      ELSE IF (NOTA) THEN
          IF (CONJB) THEN
*
*           Form  C := alpha*A*B**H + beta*C.
*
              DO 200 J = 1,N
                  IF (BETA.EQ.ZERO) THEN
                      DO 160 I = 1,M
                          C(I,J) = ZERO
  160                 CONTINUE
                  ELSE IF (BETA.NE.ONE) THEN
                      DO 170 I = 1,M
                          C(I,J) = BETA*C(I,J)
  170                 CONTINUE
                  END IF
                  DO 190 L = 1,K
                      TEMP = ALPHA*CONJG(B(J,L))
                      DO 180 I = 1,M
                          C(I,J) = C(I,J) + TEMP*A(I,L)
  180                 CONTINUE
  190             CONTINUE
  200         CONTINUE
          ELSE
*
*           Form  C := alpha*A*B**T + beta*C
*
              DO 250 J = 1,N
                  IF (BETA.EQ.ZERO) THEN
                      DO 210 I = 1,M
                          C(I,J) = ZERO
  210                 CONTINUE
                  ELSE IF (BETA.NE.ONE) THEN
                      DO 220 I = 1,M
                          C(I,J) = BETA*C(I,J)
  220                 CONTINUE
                  END IF
                  DO 240 L = 1,K
                      TEMP = ALPHA*B(J,L)
                      DO 230 I = 1,M
                          C(I,J) = C(I,J) + TEMP*A(I,L)
  230                 CONTINUE
  240             CONTINUE
  250         CONTINUE
          END IF
      ELSE IF (CONJA) THEN
          IF (CONJB) THEN
*
*           Form  C := alpha*A**H*B**H + beta*C.
*
              DO 280 J = 1,N
                  DO 270 I = 1,M
                      TEMP = ZERO
                      DO 260 L = 1,K
                          TEMP = TEMP + CONJG(A(L,I))*CONJG(B(J,L))
  260                 CONTINUE
                      IF (BETA.EQ.ZERO) THEN
                          C(I,J) = ALPHA*TEMP
                      ELSE
                          C(I,J) = ALPHA*TEMP + BETA*C(I,J)
                      END IF
  270             CONTINUE
  280         CONTINUE
          ELSE
*
*           Form  C := alpha*A**H*B**T + beta*C
*
              DO 310 J = 1,N
                  DO 300 I = 1,M
                      TEMP = ZERO
                      DO 290 L = 1,K
                          TEMP = TEMP + CONJG(A(L,I))*B(J,L)
  290                 CONTINUE
                      IF (BETA.EQ.ZERO) THEN
                          C(I,J) = ALPHA*TEMP
                      ELSE
                          C(I,J) = ALPHA*TEMP + BETA*C(I,J)
                      END IF
  300             CONTINUE
  310         CONTINUE
          END IF
      ELSE
          IF (CONJB) THEN
*
*           Form  C := alpha*A**T*B**H + beta*C
*
              DO 340 J = 1,N
                  DO 330 I = 1,M
                      TEMP = ZERO
                      DO 320 L = 1,K
                          TEMP = TEMP + A(L,I)*CONJG(B(J,L))
  320                 CONTINUE
                      IF (BETA.EQ.ZERO) THEN
                          C(I,J) = ALPHA*TEMP
                      ELSE
                          C(I,J) = ALPHA*TEMP + BETA*C(I,J)
                      END IF
  330             CONTINUE
  340         CONTINUE
          ELSE
*
*           Form  C := alpha*A**T*B**T + beta*C
*
              DO 370 J = 1,N
                  DO 360 I = 1,M
                      TEMP = ZERO
                      DO 350 L = 1,K
                          TEMP = TEMP + A(L,I)*B(J,L)
  350                 CONTINUE
                      IF (BETA.EQ.ZERO) THEN
                          C(I,J) = ALPHA*TEMP
                      ELSE
                          C(I,J) = ALPHA*TEMP + BETA*C(I,J)
                      END IF
  360             CONTINUE
  370         CONTINUE
          END IF
      END IF
*
      RETURN
*
*     End of CGEMM .
*
      END


*DECK D9LGIC
      DOUBLE PRECISION FUNCTION D9LGIC (A, X, ALX)
C***BEGIN PROLOGUE  D9LGIC
C***SUBSIDIARY
C***PURPOSE  Compute the log complementary incomplete Gamma function
C            for large X and for A .LE. X.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7E
C***TYPE      DOUBLE PRECISION (R9LGIC-S, D9LGIC-D)
C***KEYWORDS  COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, LARGE X,
C             LOGARITHM, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Compute the log complementary incomplete gamma function for large X
C and for A .LE. X.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900720  Routine changed from user-callable to subsidiary.  (WRB)
C***END PROLOGUE  D9LGIC
      DOUBLE PRECISION A, X, ALX, EPS, FK, P, R, S, T, XMA, XPA, D1MACH
      SAVE EPS
      DATA EPS / 0.D0 /
C***FIRST EXECUTABLE STATEMENT  D9LGIC
      IF (EPS.EQ.0.D0) EPS = 0.5D0*D1MACH(3)
C
      XPA = X + 1.0D0 - A
      XMA = X - 1.D0 - A
C
      R = 0.D0
      P = 1.D0
      S = P
      DO 10 K=1,300
        FK = K
        T = FK*(A-FK)*(1.D0+R)
        R = -T/((XMA+2.D0*FK)*(XPA+2.D0*FK)+T)
        P = R*P
        S = S + P
        IF (ABS(P).LT.EPS*S) GO TO 20
 10   CONTINUE
      CALL XERMSG ('SLATEC', 'D9LGIC',
     +   'NO CONVERGENCE IN 300 TERMS OF CONTINUED FRACTION', 1, 2)
C
 20   D9LGIC = A*ALX - X + LOG(S/XPA)
C
      RETURN
      END


subroutine ca_ext_src(lo,hi, &
                      old_state,old_state_l1,old_state_l2,old_state_h1,old_state_h2,&
                      new_state,new_state_l1,new_state_l2,new_state_h1,new_state_h2,&
                      src,src_l1,src_l2,src_h1,src_h2,problo,dx,time,dt)

  use amrex_constants_module, only: THIRD
  use meth_params_module, only : NVAR, UEDEN, UEINT, URHO, UTEMP, UFS
  use network, only: network_species_index

  use amrex_fort_module, only : rt => amrex_real
  implicit none
  integer         , intent(in   ) :: lo(2),hi(2)
  integer         , intent(in   ) :: old_state_l1,old_state_l2,old_state_h1,old_state_h2
  integer         , intent(in   ) :: new_state_l1,new_state_l2,new_state_h1,new_state_h2
  integer         , intent(in   ) :: src_l1,src_l2,src_h1,src_h2
  real(rt)        , intent(in   ) :: old_state(old_state_l1:old_state_h1,old_state_l2:old_state_h2,NVAR)
  real(rt)        , intent(in   ) :: new_state(new_state_l1:new_state_h1,new_state_l2:new_state_h2,NVAR)
  real(rt)        , intent(  out) :: src(    src_l1:  src_h1,  src_l2:src_h2  ,NVAR)
  real(rt)        , intent(in   ) :: problo(2),dx(2),time,dt

  integer          :: i,j
  real(rt)         :: x,y

  real(rt)        :: H, ey, y_layer, H_0, L_x, pi
  real(rt)        :: H_max

  integer, save :: ic12, im24, io16

  logical, save :: firstCall = .true.

  if (firstCall) then
     ic12 = network_species_index("carbon-12")
     io16 = network_species_index("oxygen-16")
     im24 = network_species_index("magnesium-24")
     firstCall = .false.
  endif

  src(lo(1):hi(1),lo(2):hi(2),:) = 0.e0_rt
  H_max = 0.e0_rt

  y_layer = 1.25e8_rt
  L_x = 2.5e8_rt
  pi = 3.1415926535897932384626433e0_rt
  H_0 = 2.5e16_rt

  do j = lo(2),hi(2)
      y = (dble(j)+0.5e0_rt)*dx(2)
      ey = exp(-(y-y_layer)*(y-y_layer)/1.e14_rt)
      do i = lo(1),hi(1)
         x =  (dble(i)+0.5e0_rt)*dx(1)

         H = ey*(1.e0_rt + &
                .00625_rt * sin( 2*pi*x/L_x) &
              + .01875_rt * sin((6*pi*x/L_x) + pi/3.e0_rt) &
              + .01250_rt * sin((8*pi*x/L_x) + pi/5.e0_rt))

        ! Source terms
        src(i,j,UEDEN) = new_state(i,j,URHO) * H * 2.5e16_rt
        src(i,j,UEINT) = src(i,j,UEDEN)

        ! H_max = max(H_max, src(i,j,UEDEN))

      end do
  end do

end subroutine ca_ext_src


C++****************************************************************
C Program SNR_BISPEC
C To compute the SNR of the bispectrum (phase factor)
C (not finished yet!)
C Using formula from Dainty and Greenaway (1979, JOSA, 69,5,786)
C
C JLP
C Version: 30-03-90
C--****************************************************************
	PROGRAM SNR_BISPEC
	PARAMETER(IDIM=256)
	CHARACTER NAME*40,COMMENTS*80
	REAL MODSQ(IDIM,IDIM),SNRM(IDIM,IDIM)

C Format of the files:
	PRINT *,' WARNING: all the files should not have odd',
     1	' numbers for NX and NY (size in X and Y)'
	CALL JLP_INQUIFMT

C Input of the bispectrum:
	WRITE(6,37)
37	FORMAT(' Bispectrum list :')
	NAME=' '
	CALL JLP_READIMAG(BISP1,NX,NY,IDIM,NAME,COMMENTS)

	CALL SNR_BISP(BISP1,NX,NY,IDIM,SNRM)

	WRITE(COMMENTS,11) NAME(1:10)
11	FORMAT(' SNR of the spectrum:',A10)
	NAME=' '
	CALL JLP_WRITEIMAG(SNRM,NX,NY,IDIM,NAME,COMMENTS)

	CALL JLP_END
	END

C*******************************************************************
C SNR_MODSQ
C Computes the SNR of the modulus of the spectrum (squared)
C Uses the formula from Dainty and Greenaway (1979, JOSA, 69,5,786)
C*******************************************************************
	SUBROUTINE SNR_MODSQ(MODSQ,NX,NY,IDIM,SNRM)
	INTEGER NX,NY,IDIM,IXC,IYC,W1
	REAL MODSQ(IDIM,*),SNRM(IDIM,*)

C Center:
	IXC=(NX/2)+1
	IYC=(NY/2)+1
C Number of photons:
	IF(SNRM(IXC,IYC).LE.0)THEN
	  WRITE(6,93)
93	  FORMAT(' Fatal error: the mean number of photons',
     1	'per frame is null!')
	  CALL EXIT
	ENDIF
	PHOT=SQRT(SNRM(IXC,IYC))

C Main loop:
C Formula from Dainty and Greenaway (1979, JOSA, 69,5,786)
	DO 91 J=0,NY/2
	  J1=IYC+J
	  J2=IYC+2*J
	  DO 92 I=0,NX/2
	    I1=IXC+I
	    I2=IXC+2*I
	    W1=MODSQ(I1,J1)/PHOT
	    IF((I2.GT.NX).OR.(J2.GT.NY))THEN
	      W2=W1/(1.+W1)
	    ELSE
	      W2=W1/SQRT((1.+W1)*(1.+W1)+MODSQ(I2,J2)/PHOT**2)
	    ENDIF
	    SNRM(IXC+I,IYC+J)=W2
	    SNRM(IXC+I,IYC-J)=W2
	    SNRM(IXC-I,IYC+J)=W2
	    SNRM(IXC-I,IYC-J)=W2
92	  CONTINUE
91	CONTINUE

	RETURN
	END


! -*- mode: F90 ; mode: font-lock ; column-number-mode: true ; vc-back-end: RCS -*-
!=============================================================================!
!                                 U T I L                                     !
!=============================================================================!
!                                                                             !
! $Id: util.f90,v 1.1.1.1.2.1 2007/11/06 16:12:57 ccseac Exp $
!                                                                             !
!-----------------------------------------------------------------------------!
! Contains ancilliary utility routines used throughout the code. Many of      !
! these will be inlined manually when used for efficiency.                    !
!-----------------------------------------------------------------------------!
!                                                                             !
! $Log$
!
!
!=============================================================================!

module util

  use iso_c_binding
  implicit none

  ! Double precision
  integer,parameter :: dp = c_double

  ! pi
  real(kind=dp),parameter :: Pi = 3.141592653589793238462643383279502884197_dp
  real(kind=dp),parameter :: invPi = 1.0_dp/3.141592653589793238462643383279502884197_dp

  contains

  real(kind=dp) function util_determinant(matrix)
    !------------------------------------------------------------------------------!
    ! Computes the determinant of a 3x3 matrix.                                    !
    !------------------------------------------------------------------------------!
    ! D.Quigley September 2006                                                     !
    !------------------------------------------------------------------------------!

    implicit none
    real(kind=dp),dimension(3,3) :: matrix

    real(kind=dp) :: det

    Det = Matrix(1,1)*(Matrix(2,2)*Matrix(3,3) - &
          Matrix(2,3)*Matrix(3,2))
    Det = Det - Matrix(1,2)*(Matrix(2,1)*Matrix(3,3) - &
          Matrix(2,3)*Matrix(3,1))
    Det = Det + Matrix(1,3)*(Matrix(2,1)*Matrix(3,2) - &
          Matrix(2,2)*Matrix(3,1))

    util_determinant = det

    !if ( det < tiny(0.0_dp) ) stop 'Error in util_determinant'

    return

  end function util_determinant

  subroutine util_recipmatrix(hmatrix,recip_matrix)
    !------------------------------------------------------------------------------!
    ! Calculates the matrix of reciprocal lattive vectors from the h_matrix        !
    !------------------------------------------------------------------------------!
    ! D.Quigley September 2006                                                     !
    !------------------------------------------------------------------------------!
    implicit none
    real(kind=dp),dimension(3,3),intent(in)  :: hmatrix
    real(kind=dp),dimension(3,3),intent(out) :: recip_matrix
    real(kind=dp) :: vol

    ! invert hmatrix to get recip_matrix
    recip_matrix(1,1)=hmatrix(2,2)*hmatrix(3,3)-hmatrix(2,3)*hmatrix(3,2)
    recip_matrix(1,2)=hmatrix(2,3)*hmatrix(3,1)-hmatrix(2,1)*hmatrix(3,3)
    recip_matrix(1,3)=hmatrix(2,1)*hmatrix(3,2)-hmatrix(2,2)*hmatrix(3,1)

    recip_matrix(2,1)=hmatrix(1,3)*hmatrix(3,2)-hmatrix(1,2)*hmatrix(3,3)
    recip_matrix(2,2)=hmatrix(1,1)*hmatrix(3,3)-hmatrix(1,3)*hmatrix(3,1)
    recip_matrix(2,3)=hmatrix(1,2)*hmatrix(3,1)-hmatrix(1,1)*hmatrix(3,2)

    recip_matrix(3,1)=hmatrix(1,2)*hmatrix(2,3)-hmatrix(1,3)*hmatrix(2,2)
    recip_matrix(3,2)=hmatrix(1,3)*hmatrix(2,1)-hmatrix(1,1)*hmatrix(2,3)
    recip_matrix(3,3)=hmatrix(1,1)*hmatrix(2,2)-hmatrix(1,2)*hmatrix(2,1)

    ! Calculte cell volume
    vol =hmatrix(1,1)*recip_matrix(1,1) + &
         hmatrix(1,2)*recip_matrix(1,2) + &
         hmatrix(1,3)*recip_matrix(1,3)

    ! Scale reciprocal lattice by 2*pi/volume
    recip_matrix(:,:)=recip_matrix(:,:)*2.0_dp*Pi/vol

    return

  end subroutine util_recipmatrix

  subroutine util_images(v_ss,hmatrix,recip_matrix)
    !------------------------------------------------------------------------------!
    ! Computes the minimum image of a vector v_ss - Note that this is inlined for  !
    ! efficiency in most cases.                                                    !
    !------------------------------------------------------------------------------!
    ! D.Quigley September 2006                                                     !
    !------------------------------------------------------------------------------!
    implicit none
    real(kind=dp),dimension(3),intent(inout) :: v_ss
    real(kind=dp),dimension(3,3),intent(in)  :: hmatrix,recip_matrix

    real(kind=dp) :: sx,sy,sz
    real(kind=dp) :: ssx,ssy,ssz

    integer :: idim

    ! compute fractional co-ordinates
    sx = recip_matrix(1,1)*v_ss(1) + &
         recip_matrix(2,1)*v_ss(2) + &
         recip_matrix(3,1)*v_ss(3)
    sy = recip_matrix(1,2)*v_ss(1) + &
         recip_matrix(2,2)*v_ss(2) + &
         recip_matrix(3,2)*v_ss(3)
    sz = recip_matrix(1,3)*v_ss(1) + &
         recip_matrix(2,3)*v_ss(2) + &
         recip_matrix(3,3)*v_ss(3)

    sx = sx*0.5_dp*invPi
    sy = sy*0.5_dp*invPi
    sz = sz*0.5_dp*invPi

    ! apply boundary conditions
    ssx = sx - floor(sx+0.5_dp,kind=dp)
    ssy = sy - floor(sy+0.5_dp,kind=dp)
    ssz = sz - floor(sz+0.5_dp,kind=dp)

    ! scale back up
    do idim=1,3
       v_ss(idim) = hmatrix(idim,1)*ssx + &
                    hmatrix(idim,2)*ssy + &
                    hmatrix(idim,3)*ssz
    end do

    return

  end subroutine util_images

end module util


SUBROUTINE brdc2ecef(GPST,EPH,CLK,ECEFPOS,SATCLK)

! NAME       :  brdc2ecef.f90
!
! PURPOSE    :  Convert the broadcast elements to ECEF coordinates
!
! PARAMETERS :
!         IN :  GPST     :  GPS time
!               EPH      :  broadcast parameters
!               EPH(2)   :  toe
!               EPH(3)   :  semi-major axis
!               EPH(4)   :  eccentricity
!               EPH(5)   :  inclination
!               EPH(6)   :  right ascension of ascending node
!               EPH(7)   :  perigee
!               EPH(8)   :  mean anomaly
!               EPH(9)   :  correction to mean motion
!               EPH(10)  :  rate of node
!               EPH(11)  :  cus
!               EPH(12)  :  cuc
!               EPH(13)  :  crs
!               EPH(14)  :  crc
!               EPH(15)  :  cis
!               EPH(16)  :  cic
!               EPH(18)  :  idot
!
!        OUT :  ECEFPOS  :  ECEF coordinates
!
! Author: Tzupang Tseng
!
! Create: 18-09-2019
!
! Corpyright: Geoscience Australia

USE mdl_precision
IMPLICIT NONE

INTEGER :: I
REAL (KIND = prec_d) :: GPST
REAL (KIND = prec_d) :: CLK(3),EPH(20),ECEFPOS(3),SATCLK
REAL (KIND = prec_d) :: axis, toe, DT
REAL (KIND = prec_d) :: u0, u
REAL (KIND = prec_d) :: Et, e
REAL (KIND = prec_d) :: v
REAL (KIND = prec_d) :: cus,cuc,crs,crc,cis,cic
REAL (KIND = prec_d) :: w0, inc0, idot
REAL (KIND = prec_d) :: w, it, r
REAL (KIND = prec_d) :: ascnode0, ascnode,dot_ascnode
REAL (KIND = prec_d) :: GM, OMEGA

OMEGA  = 7292115.1467D-11 ! RAD/SEC
GM     = 398.6004415D12   ! M**3/SEC**

!
! Convert the broadcast to ECEF coordinates
! Time elapse since toe
! --------------------------
toe = EPH(2)
DT=GPST-toe

IF(DT.GT. 302400.D0)DT=DT-604800.D0
IF(DT.LT.-302400.D0)DT=DT+604800.D0
!print*,'DT =',DT
! Mean anomaly at GPST
! --------------------
axis = EPH(3)
u0   = EPH(8)
u    =u0+(sqrt(GM/axis**3)+EPH(9))*DT
!print*,'mean anomaly', u
! Iteration solution of eccentricity anomaly
! ---------------------------------------
Et=u
e=EPH(4)
DO I=1,10
Et=u+e*sin(Et)
ENDDO
!print*,'eccentricity anomaly', Et
! True anomaly
! -------------
v=2.D0*DATAN(DSQRT((1.D0+e)/(1.D0-e))*DTAN(Et/2.D0))
!print*,'true anomaly',v
! Correct for orbital perturbations
! ----------------------------------
cus =  EPH(11)
cuc =  EPH(12)
crs =  EPH(13)
crc =  EPH(14)
cis =  EPH(15)
cic =  EPH(16)

w0   = EPH(7) + v
inc0 = EPH(5)
idot = EPH(18)
! Argument of perigee
w  = w0                 + cuc*cos(2.D0*w0) + cus*sin(2.D0*w0)
! Radial distance
r  = axis*(1-e*cos(Et)) + crc*cos(2.D0*w0) + crs*sin(2.D0*w0)
! Inclination
it = inc0 + idot*DT     + cic*cos(2.D0*w0) + cis*sin(2.D0*w0)
!print*,'Argument of perigee, Radial distance, Inclination',w,r,it
! Compute the right ascension of ascending node
! ---------------------------------------------
ascnode0     = EPH(6)
dot_ascnode  = EPH(10)
ascnode=ascnode0+(dot_ascnode-OMEGA)*DT-OMEGA*toe
!print*,'right ascension of ascending node',ascnode

! Convert the Keplerian parameters to ECEF coordinates
! ------------------------------------------------------
ECEFPOS(1)=r*cos(w)*cos(ascnode) - r*sin(w)*cos(it)*sin(ascnode)
ECEFPOS(2)=r*cos(w)*sin(ascnode) + r*sin(w)*cos(it)*cos(ascnode)
ECEFPOS(3)=r*sin(w)*sin(it)
!print*,'ECEFPOS =', ECEFPOS
! Convert to the unit required in SP3 file
SATCLK = 1.D6*(CLK(1) + CLK(2)*DT + CLK(3)*DT**2)

END


      COMPLEX*16 FUNCTION JINTW_Wdec(M12,M22,P2)
*------------------------------------------
      IMPLICIT NONE!
*-------------------
      REAL*8 P2,DABS
      COMPLEX*16 M12,M22,SQR,P2P,P2M,X1,X2,SQRT,LOG
*-
      SQR=SQRT(P2**2+2D0*P2*(M12+M22)+(M12-M22)**2)
***   X1=(P2-M12+M22+SQR)/2D0/P2
***   X2=(P2-M12+M22-SQR)/2D0/P2
      IF(DREAL(M12).LE.DREAL(M22)) THEN
        P2P=P2-M12+M22+SQR
        P2M=P2-M12+M22-SQR
        IF(DABS(DREAL(P2P)).GE.DABS(DREAL(P2M))) THEN
         X1=P2P/2D0/P2
         X2=-2D0*M12/P2P
        ELSE
         X2=P2M/2D0/P2
         X1=-2D0*M12/P2M
        ENDIF
      ELSE
        P2P=P2-M22+M12+SQR
        P2M=P2-M22+M12-SQR
        IF(DABS(DREAL(P2P)).GE.DABS(DREAL(P2M))) THEN
         X1=P2P/2D0/P2
         X2=-2D0*M22/P2P
        ELSE
         X2=P2M/2D0/P2
         X1=-2D0*M22/P2M
        ENDIF
      ENDIF
*-
      JINTW_Wdec=-(LOG(1D0-1D0/X2)-LOG(1D0-1D0/X1))
*-
      RETURN
      END