! { dg-do run }
! Check the fix for PR48462 in which the assignments involving matmul
! seg faulted because a was automatically freed before the assignment.
! Since it is related, the test for the fix of PR48746 has been added
! as a subroutine by that name.
!
! Contributed by John Nedney  <ortp21@gmail.com>
!
program main
  implicit none
  integer, parameter :: dp = kind(0.0d0)
  real(kind=dp), allocatable :: delta(:,:)
  real(kind=dp), allocatable, target :: a(:,:)
  real(kind=dp), pointer :: aptr(:,:)

  allocate(a(3,3))
  aptr => a

  call foo
  if (.not. associated (aptr, a)) call abort () ! reallocated to same size - remains associated
  call bar
  if (.not. associated (aptr, a)) call abort () ! reallocated to smaller size - remains associated
  call foobar
  if (associated (aptr, a)) call abort () ! reallocated to larger size - disassociates

  call pr48746
contains
!
! Original reduced version from comment #2
  subroutine foo
    implicit none
    real(kind=dp), allocatable :: b(:,:)

    allocate(b(3,3))
    allocate(delta(3,3))

    a = reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3])
    b = reshape ([1d0, 0d0, 0d0, 0d0, 1d0, 0d0, 0d0, 0d0, 1d0], [3,3])

    a = matmul( matmul( a, b ), b )
    delta = (a - reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3]))**2
    if (any (delta > 1d-12)) call abort
    if (any (lbound (a) .ne. [1, 1])) call abort
  end subroutine
!
! Check that all is well when the shape of 'a' changes.
  subroutine bar
    implicit none
    real(kind=dp), allocatable :: a(:,:)
    real(kind=dp), allocatable :: b(:,:)

    b = reshape ([1d0, 1d0, 1d0], [3,1])
    a = reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3])

    a = matmul( a, matmul( a, b ) )

    delta = (a - reshape ([198d0, 243d0, 288d0], [3,1]))**2
    if (any (delta > 1d-12)) call abort
    if (any (lbound (a) .ne. [1, 1])) call abort
  end subroutine
  subroutine foobar
    integer :: i
    a = reshape ([(real(i, dp), i = 1, 100)],[10,10])
  end subroutine
  subroutine pr48746
! This is a further wrinkle on the original problem and came about
! because the dtype field of the result argument, passed to matmul,
! was not being set. This is needed by matmul for the rank.
!
! Contributed by Thomas Koenig  <tkoenig@gcc.gnu.org>
!
    implicit none
    integer, parameter :: m=10, n=12, count=4
    real :: optmatmul(m, n)
    real :: a(m, count), b(count, n), c(m, n)
    real, dimension(:,:), allocatable :: tmp
    call random_number(a)
    call random_number(b)
    tmp = matmul(a,b)
    if (any (lbound (tmp) .ne. [1,1])) call abort
    if (any (ubound (tmp) .ne. [10,12])) call abort
  end subroutine
end program main


	SUBROUTINE GR_NDCP  ( np, axary, ndec, iret )
C************************************************************************
C* GR_NDCP								*
C*									*
C* This subroutine computes the number of decimal places to use with	*
C* an array of data.							*
C*									*
C* GR_NDCP  ( NP, AXARY, NDEC, IRET )					*
C*									*
C* Input parameters:							*
C*	NP		INTEGER		Number of data values		*
C*	AXARY (NP)	REAL		Data values			*
C*									*
C* Output parameters:							*
C*	NDEC		INTEGER		Number of decimal places	*
C*	IRET		INTEGER		Return code			*
C**									*
C* M. desJardins/GSFC	 7/89						*
C* M. desJardins/GSFC	 7/90	Check for large numbers before NINT	*
C* S. Jacobs/EAI	10/93	Renamed from CNDECP			*
C************************************************************************
	INCLUDE		'ERROR.PRM'
C*
	REAL		axary (*)
C------------------------------------------------------------------------
	iret = NORMAL
	ndec = 0
C
C*	First check for large values.
C
	DO  i = 1, np
	    IF  ( axary (i) .gt. 1.E5 )  THEN
		ndec = -1
		RETURN
	    END IF
	END DO
C
C*	Loop through all values checking for number of decimal places.
C
	DO  i = 1, np
	    iax    = NINT ( axary (i) )
	    dif1   = ABS ( FLOAT ( iax ) - axary (i) )
	    ax10   = axary (i) * 10.
	    iax10  = NINT ( ax10 )
	    dif10  = ABS ( FLOAT ( iax10 ) - ax10 )
	    ax100  = axary (i) * 100.
	    iax100 = NINT ( ax100 )
	    dif100 = ABS ( FLOAT ( iax100 ) - ax100 )
	    IF  ( ( ndec .le. 0 ) .and.
     +		  ( dif1 .lt. .001 ) )  THEN
	      ELSE IF  ( ( ndec .le. 1 ) .and.
     +			 ( dif10 .lt. .01 ) )  THEN
		ndec = 1
	      ELSE IF  ( ( ndec .le. 2 ) .and.
     +			 ( dif100 .lt. .1 ) )  THEN
		ndec = 2
	      ELSE
		ndec = 3
		RETURN
	    END IF
	END DO
C*
	RETURN
	END


program leap_test_main
  use TesterMain
  use leap
  implicit none

  ! Test 1: year not divisible by 4 in common year
  call assert_equal(.false., is_leap_year(2015),"year not divisible by 4 in common year")
  ! Test 2: year divisible by 2, not divisible by 4 in common year
  call assert_equal(.false., is_leap_year(1970), "year divisible by 2, not divisible by 4 in common year")
  ! Test 3: year divisible by 4, not divisible by 100 in leap year
  call assert_equal(.true., is_leap_year(1996), "year divisible by 4, not divisible by 100 in leap year")
  ! Test 4: year divisible by 4 and 5 is still a leap year
  call assert_equal(.true., is_leap_year(1960), "year divisible by 4 and 5 is still a leap year")
  ! Test 5: year divisible by 100, not divisible by 400 in common year
  call assert_equal(.false., is_leap_year(2100), "year divisible by 100, not divisible by 400 in common year")
  ! Test 6: year divisible by 100 but not by 3 is still not a leap year
  call assert_equal(.false., is_leap_year(1900), "year divisible by 100 but not by 3 is still not a leap year")
  ! Test 7: year divisible by 400 is leap year
  call assert_equal(.true., is_leap_year(2000), "year divisible by 400 is leap year")
  ! Test 8: year divisible by 400 but not by 125 is still a leap year
  call assert_equal(.true., is_leap_year(2400), "year divisible by 400 but not by 125 is still a leap year")
  ! Test 9: year divisible by 200, not divisible by 400 in common year
  call assert_equal(.false., is_leap_year(1800), "year divisible by 200, not divisible by 400 in common year")

  call test_report()

end program


cdis    Forecast Systems Laboratory
cdis    NOAA/OAR/ERL/FSL
cdis    325 Broadway
cdis    Boulder, CO     80303
cdis
cdis    Forecast Research Division
cdis    Local Analysis and Prediction Branch
cdis    LAPS
cdis
cdis    This software and its documentation are in the public domain and
cdis    are furnished "as is."  The United States government, its
cdis    instrumentalities, officers, employees, and agents make no
cdis    warranty, express or implied, as to the usefulness of the software
cdis    and documentation for any purpose.  They assume no responsibility
cdis    (1) for the use of the software and documentation; or (2) to provide
cdis     technical support to users.
cdis
cdis    Permission to use, copy, modify, and distribute this software is
cdis    hereby granted, provided that the entire disclaimer notice appears
cdis    in all copies.  All modifications to this software must be clearly
cdis    documented, and are solely the responsibility of the agent making
cdis    the modifications.  If significant modifications or enhancements
cdis    are made to this software, the FSL Software Policy Manager
cdis    (softwaremgr@fsl.noaa.gov) should be notified.
cdis
cdis
cdis
cdis
cdis
cdis
cdis
!       i4time = i4time_now_gg()
!       rlat = 40.
!       rlon = -105.
!       call solar_position(rlat,rlon,i4time,alt,dec,hrangle)
!       write(6,*)'hrangle,dec,alt',hrangle,dec,alt
!       end

        SUBROUTINE solar_position(rlat,rlon,i4time,alt,dec,hrangle)

C Steve Albers Jan 1994
C Argument      I/O     Type                    Description
C --------      ---     ----    -----------------------------------------------
C RLAT           I      R*4     Latitude (degrees)
C RLON           I      R*4     Longitude (degrees)
C I4TIME         I      I*4     Time (seconds since 1-1-1960)
C ALT            O      R*4     Solar Elevation Angle (degrees)
C DEC            O      R*4     Solar Declination (degrees)
C HRANGLE        O      R*4     Solar Hour Angle (degrees)
        include 'trigd.inc'
        character*9 asc9_time

        PI=3.14159265
        RPD=PI/180.
        call make_fnam_lp(i4time,asc9_time,istatus)

        read(asc9_time,1)jd
1       format(2x,i3)

        read(asc9_time,2)ih
2       format(5x,i2)

        read(asc9_time,3)im
3       format(7x,i2)

        is = i4time - ((i4time / 60) * 60)

        EQT=TIMEQ2(i4time)/rpd          ! Equation of Time (Degrees)
        DEC=SOLDEC2(i4time)/rpd         ! Solar declination (Degrees)
        hrangle = (ih-12)*15. + im/4. + is/240. + rlon + EQT

        COSZEN=SIND(RLAT)*SIND(DEC)+COSD(RLAT)*COSD(DEC)*COSD(hrangle)
        alt = 90. - ACOSD(COSZEN)       ! Solar Altitude (Degrees)

        if(hrangle .lt. -180.)hrangle = hrangle + 360.
        if(hrangle .gt. +180.)hrangle = hrangle - 360.

!       write(6,*)'jd,ih,im',jd,ih,im
!       write(6,*)'hrangle,dec,alt',hrangle,dec,alt

        RETURN
        END

        SUBROUTINE solalt(rlat,rlon,i4time,alt)

C Steve Albers Jan 1994
C Argument      I/O     Type                    Description
C --------      ---     ----    -----------------------------------------------
C RLAT           I      R*4     Latitude (degrees)
C RLNG           I      R*4     Longitude (degrees)
       include 'trigd.inc'
        character*9 asc9_time

        PI=3.14159265
        RPD=PI/180.
        call make_fnam_lp(i4time,asc9_time,istatus)

        read(asc9_time,1)jd
1       format(2x,i3)

        read(asc9_time,2)ih
2       format(5x,i2)

        read(asc9_time,3)im
3       format(7x,i2)

        EQT=TIMEQ2(i4time)/rpd          ! Equation of Time (Degrees)
        DEC=SOLDEC2(i4time)/rpd         ! Solar declination (Degrees)
        HRANGLE = (ih-12)*15. + im/4. + rlon + EQT

        COSZEN=SIND(RLAT)*SIND(DEC)+COSD(RLAT)*COSD(DEC)*COSD(HRANGLE)
        alt = 90. - ACOSD(COSZEN)       ! Solar Altitude (Degrees)

!       write(6,*)'jd,ih,im',jd,ih,im
!       write(6,*)'hrangle,dec,alt',hrangle,dec,alt

        RETURN
        END

        SUBROUTINE get_solalt_2d(rlat_a,rlon_a,i4time,ni,nj,alt)

C Steve Albers Jan 1994
C Argument      I/O     Type                    Description
C --------      ---     ----    -----------------------------------------------
C RLAT           I      R*4     Latitude (degrees)
C RLNG           I      R*4     Longitude (degrees)
        include 'trigd.inc'
        character*9 asc9_time

        real rlat_a(ni,nj)
        real rlon_a(ni,nj)
        real alt(ni,nj)

        PI=3.14159265
        RPD=PI/180.
        call make_fnam_lp(i4time,asc9_time,istatus)

        read(asc9_time,1)jd
1       format(2x,i3)

        read(asc9_time,2)ih
2       format(5x,i2)

        read(asc9_time,3)im
3       format(7x,i2)

        EQT=TIMEQ2(i4time)/rpd          ! Equation of Time (Degrees)
        DEC=SOLDEC2(i4time)/rpd         ! Solar declination (Degrees)

        do i = 1,ni
        do j = 1,nj

          rlat = rlat_a(i,j)
          rlon = rlon_a(i,j)

          HRANGLE = (ih-12)*15. + im/4. + rlon + EQT

          COSZEN=SIND(RLAT)*SIND(DEC)+COSD(RLAT)*COSD(DEC)*COSD(HRANGLE)
          alt(i,j) = 90. - ACOSD(COSZEN)       ! Solar Altitude (Degrees)

        enddo ! j
        enddo ! i

!       write(6,*)'jd,ih,im',jd,ih,im
!       write(6,*)'hrangle,dec,alt',hrangle,dec,alt

        RETURN
        END

C       J. Wakefield    28 Jan 82       Original version

C***These formulas are from Paltridge and Platt, 1976.  They reference Spencer,
C***1971 for the solar declination and equation of time.
C------------------------------------------------------------------------------
        FUNCTION RADNORM(JD)
C***Normalized earth-sun distance factor (R0/R)**2
C***JD is input Julian day number
        DAYANG1=2.*3.14159265*(JD-1)/365.
        DAYANG2=2.*DAYANG1

        RADNORM= 1.000110
     1          +0.034221*COS(DAYANG1)+0.001280*SIN(DAYANG1)
     2          +0.000719*COS(DAYANG2)+0.000077*SIN(DAYANG2)

        RETURN
        END
C------------------------------------------------------------------------------
        FUNCTION SOLDEC(JD)
C***Solar declination angle (radians)
C***JD is input Julian day number
        DAYANG1=2.*3.14159265*(JD-1)/365.
        DAYANG2=2.*DAYANG1
        DAYANG3=3.*DAYANG1

        SOLDEC=  0.006918
     1          -0.399912*COS(DAYANG1)+0.070257*SIN(DAYANG1)
     2          -0.006758*COS(DAYANG2)+0.000907*SIN(DAYANG2)
     3          -0.002697*COS(DAYANG3)+0.001480*SIN(DAYANG3)

        RETURN
        END
C------------------------------------------------------------------------------
        FUNCTION SOLDEC2(i4time)
C***Solar declination angle (radians)
        double precision jd,by

!       Compute Astronomical Julian Date
        call i4time_to_jd(i4time,jd,istatus)

!       Compute Besselian Year
        by = 1900.0 + (jd - 2415020.31352) / 365.242198781
        by_frac = by - int(by)

        DAYANG1=2.*3.14159265*by_frac
        DAYANG2=2.*DAYANG1
        DAYANG3=3.*DAYANG1

        SOLDEC2= 0.006918
     1          -0.399912*COS(DAYANG1)+0.070257*SIN(DAYANG1)
     2          -0.006758*COS(DAYANG2)+0.000907*SIN(DAYANG2)
     3          -0.002697*COS(DAYANG3)+0.001480*SIN(DAYANG3)

        RETURN
        END
C------------------------------------------------------------------------------
        FUNCTION TIMEQ(JD)
C***Equation of time (radians)
C***JD is input Julian day number
        DAYANG1=2.*3.14159265*(JD-1)/365.
        DAYANG2=2.*DAYANG1

        TIMEQ=   0.000075
     1          +0.001868*COS(DAYANG1)-0.032077*SIN(DAYANG1)
     2          -0.014615*COS(DAYANG2)-0.040849*SIN(DAYANG2)

        RETURN
        END
C------------------------------------------------------------------------------
        FUNCTION TIMEQ2(i4time)
C***Equation of time (radians)
        double precision jd,by

!       Compute Astronomical Julian Date
        call i4time_to_jd(i4time,jd,istatus)

!       Compute Besselian Year
        by = 1900.0 + (jd - 2415020.31352) / 365.242198781
        by_frac = by - int(by)

        DAYANG1=2.*3.14159265*by_frac
        DAYANG2=2.*DAYANG1

        TIMEQ2=  0.000075
     1          +0.001868*COS(DAYANG1)-0.032077*SIN(DAYANG1)
     2          -0.014615*COS(DAYANG2)-0.040849*SIN(DAYANG2)

        RETURN
        END


C-----------------------------------------------------------------------
      SUBROUTINE SPSYNTH(I,M,IM,IX,NC,NCTOP,KM,CLAT,PLN,PLNTOP,MP,
     &                   SPC,SPCTOP,F)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    SPSYNTH     SYNTHESIZE FOURIER FROM SPECTRAL
C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 92-10-31
C
C ABSTRACT: SYNTHESIZES FOURIER COEFFICIENTS FROM SPECTRAL COEFFICIENTS
C           FOR A LATITUDE PAIR (NORTHERN AND SOUTHERN HEMISPHERES).
C           VECTOR COMPONENTS ARE DIVIDED BY COSINE OF LATITUDE.
C
C PROGRAM HISTORY LOG:
C   91-10-31  MARK IREDELL
C
C USAGE:    CALL SPSYNTH(I,M,IM,IX,NC,NCTOP,KM,CLAT,PLN,PLNTOP,MP,
C    &                   SPC,SPCTOP,F)
C
C   INPUT ARGUMENT LIST:
C     I        - INTEGER SPECTRAL DOMAIN SHAPE
C                (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL)
C     M        - INTEGER SPECTRAL TRUNCATION
C     IM       - INTEGER EVEN NUMBER OF FOURIER COEFFICIENTS
C     IX       - INTEGER DIMENSION OF FOURIER COEFFICIENTS (IX>=IM+2)
C     NC       - INTEGER DIMENSION OF SPECTRAL COEFFICIENTS
C                (NC>=(M+1)*((I+1)*M+2))
C     NCTOP    - INTEGER DIMENSION OF SPECTRAL COEFFICIENTS OVER TOP
C                (NCTOP>=2*(M+1))
C     KM       - INTEGER NUMBER OF FIELDS
C     CLAT     - REAL COSINE OF LATITUDE
C     PLN      - REAL ((M+1)*((I+1)*M+2)/2) LEGENDRE POLYNOMIAL
C     PLNTOP   - REAL (M+1) LEGENDRE POLYNOMIAL OVER TOP
C     SPC      - REAL (NC,KM) SPECTRAL COEFFICIENTS
C     SPCTOP   - REAL (NCTOP,KM) SPECTRAL COEFFICIENTS OVER TOP
C     MP       - INTEGER (KM) IDENTIFIERS (0 FOR SCALAR, 1 FOR VECTOR)
C
C   OUTPUT ARGUMENT LIST:
C     F        - REAL (IX,2,KM) FOURIER COEFFICIENTS FOR LATITUDE PAIR
C
C ATTRIBUTES:
C   LANGUAGE: CRAY FORTRAN
C
C$$$
      REAL PLN((M+1)*((I+1)*M+2)/2),PLNTOP(M+1)
      INTEGER MP(KM)
      REAL SPC(NC,KM),SPCTOP(NCTOP,KM)
      REAL F(IX,2,KM)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  ZERO OUT FOURIER COEFFICIENTS.
      DO K=1,KM
        DO L=0,IM/2
          F(2*L+1,1,K)=0.
          F(2*L+2,1,K)=0.
          F(2*L+1,2,K)=0.
          F(2*L+2,2,K)=0.
        ENDDO
      ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  SYNTHESIS OVER POLE.
C  INITIALIZE FOURIER COEFFICIENTS WITH TERMS OVER TOP OF THE SPECTRUM.
C  INITIALIZE EVEN AND ODD POLYNOMIALS SEPARATELY.
      IF(CLAT.EQ.0) THEN
        LTOPE=MOD(M+1+I,2)
!C$OMP PARALLEL DO PRIVATE(L,KS,KP,N,F1R,F1I)
        DO K=1,KM
          IF(MP(K).EQ.1) THEN
            L=MP(K)
            IF(L.EQ.LTOPE) THEN
              F(2*L+1,1,K)=PLNTOP(L+1)*SPCTOP(2*L+1,K)
              F(2*L+2,1,K)=PLNTOP(L+1)*SPCTOP(2*L+2,K)
            ELSE
              F(2*L+1,2,K)=PLNTOP(L+1)*SPCTOP(2*L+1,K)
              F(2*L+2,2,K)=PLNTOP(L+1)*SPCTOP(2*L+2,K)
            ENDIF
          ENDIF
C  FOR EACH ZONAL WAVENUMBER, SYNTHESIZE TERMS OVER TOTAL WAVENUMBER.
C  SYNTHESIZE EVEN AND ODD POLYNOMIALS SEPARATELY.
          L=MP(K)
          KS=L*(2*M+(I-1)*(L-1))
          KP=KS/2+1
          DO N=L,I*L+M,2
            F(2*L+1,1,K)=F(2*L+1,1,K)+PLN(KP+N)*SPC(KS+2*N+1,K)
            F(2*L+2,1,K)=F(2*L+2,1,K)+PLN(KP+N)*SPC(KS+2*N+2,K)
          ENDDO
          DO N=L+1,I*L+M,2
            F(2*L+1,2,K)=F(2*L+1,2,K)+PLN(KP+N)*SPC(KS+2*N+1,K)
            F(2*L+2,2,K)=F(2*L+2,2,K)+PLN(KP+N)*SPC(KS+2*N+2,K)
          ENDDO
C  SEPARATE FOURIER COEFFICIENTS FROM EACH HEMISPHERE.
C  ODD POLYNOMIALS CONTRIBUTE NEGATIVELY TO THE SOUTHERN HEMISPHERE.
          L=MP(K)
          F1R=F(2*L+1,1,K)
          F1I=F(2*L+2,1,K)
          F(2*L+1,1,K)=F1R+F(2*L+1,2,K)
          F(2*L+2,1,K)=F1I+F(2*L+2,2,K)
          F(2*L+1,2,K)=F1R-F(2*L+1,2,K)
          F(2*L+2,2,K)=F1I-F(2*L+2,2,K)
        ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  SYNTHESIS OVER FINITE LATITUDE.
C  INITIALIZE FOURIER COEFFICIENTS WITH TERMS OVER TOP OF THE SPECTRUM.
C  INITIALIZE EVEN AND ODD POLYNOMIALS SEPARATELY.
      ELSE
        LX=MIN(M,IM/2)
        LTOPE=MOD(M+1,2)
        LTOPO=1-LTOPE
        LE=1+I*LTOPE
        LO=2-I*LTOPO
!C$OMP PARALLEL DO PRIVATE(L,KS,KP,N,F1R,F1I)
        DO K=1,KM
          IF(MP(K).EQ.1) THEN
            DO L=LTOPE,LX,2
              F(2*L+1,LE,K)=PLNTOP(L+1)*SPCTOP(2*L+1,K)
              F(2*L+2,LE,K)=PLNTOP(L+1)*SPCTOP(2*L+2,K)
            ENDDO
            DO L=LTOPO,LX,2
              F(2*L+1,LO,K)=PLNTOP(L+1)*SPCTOP(2*L+1,K)
              F(2*L+2,LO,K)=PLNTOP(L+1)*SPCTOP(2*L+2,K)
            ENDDO
          ENDIF
C  FOR EACH ZONAL WAVENUMBER, SYNTHESIZE TERMS OVER TOTAL WAVENUMBER.
C  SYNTHESIZE EVEN AND ODD POLYNOMIALS SEPARATELY.
          DO L=0,LX
            KS=L*(2*M+(I-1)*(L-1))
            KP=KS/2+1
            DO N=L,I*L+M,2
              F(2*L+1,1,K)=F(2*L+1,1,K)+PLN(KP+N)*SPC(KS+2*N+1,K)
              F(2*L+2,1,K)=F(2*L+2,1,K)+PLN(KP+N)*SPC(KS+2*N+2,K)
            ENDDO
            DO N=L+1,I*L+M,2
              F(2*L+1,2,K)=F(2*L+1,2,K)+PLN(KP+N)*SPC(KS+2*N+1,K)
              F(2*L+2,2,K)=F(2*L+2,2,K)+PLN(KP+N)*SPC(KS+2*N+2,K)
            ENDDO
          ENDDO
C  SEPARATE FOURIER COEFFICIENTS FROM EACH HEMISPHERE.
C  ODD POLYNOMIALS CONTRIBUTE NEGATIVELY TO THE SOUTHERN HEMISPHERE.
C  DIVIDE VECTOR COMPONENTS BY COSINE LATITUDE.
          DO L=0,LX
            F1R=F(2*L+1,1,K)
            F1I=F(2*L+2,1,K)
            F(2*L+1,1,K)=F1R+F(2*L+1,2,K)
            F(2*L+2,1,K)=F1I+F(2*L+2,2,K)
            F(2*L+1,2,K)=F1R-F(2*L+1,2,K)
            F(2*L+2,2,K)=F1I-F(2*L+2,2,K)
          ENDDO
          IF(MP(K).EQ.1) THEN
            DO L=0,LX
              F(2*L+1,1,K)=F(2*L+1,1,K)/CLAT
              F(2*L+2,1,K)=F(2*L+2,1,K)/CLAT
              F(2*L+1,2,K)=F(2*L+1,2,K)/CLAT
              F(2*L+2,2,K)=F(2*L+2,2,K)/CLAT
            ENDDO
          ENDIF
        ENDDO
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      END


      SUBROUTINE SDET

!     Legacy Mars GCM v24
!     Mars Climate Modeling Center
!     NASA Ames Research Center

C  PURPOSE:
C      THIS SUBROUTINE CALCULATES QUANTITIES RELATED TO THE
C      POSITION OF MARS IN ITS ORBIT.
C
C  MODIFIED FROM ORIGINAL BY
C      STEVE POHORSKY    INFORMATICS     TASK 605    JUL 82
C  FOR
C      JIM POLLACK
C  ENVIRONMENT
C      Cray-2            UNICOS 3.0      FORTRAN
C  REVISION HISTORY
C
C  INPUT PARAMETERS
C      SDEYR, SDEDY, & ?
C  OUTPUT PARAMETERS
C      COSD, SIND, RDIST, SDEYR, SDEDY, & ?
C  CALLED BY
C      MAIN,INSDET
C
      use grid_h
      use defines_h
      use constants_h, only: PI
      use standard_h

      implicit none

C######################################################################

      INTEGER DY

      integer :: maxday
      real*8  :: quad, si, co, x, arsin, arcos, raddeg, hellon, eta
      real*8  :: eta2, eta1, beta, anomtp, cose, sine, v1, v2, anomt
      real*8  :: dec

      QUAD(SI,CO) = PI-SIGN(PI-CO,SI)
      ARSIN(X)    = ASIN(X)
      ARCOS(X)    = ACOS(X)

C#=====================================================================

C     CALCULATES ORBITAL INFORMATION:  DISTANCE TO SUN, SOLAR
C     DECLINATION, HELIOCENTRIC LONGITUDE, AND TRUE ANOMOLY FROM
C     SPRING EQUINOX IN NORTHERN HEMISPHERE

      IGROW = IGROW+1

      IF(IGROW.GT.IGMAX) THEN
        DCLK =.TRUE.
      ENDIF

      IF(IGROW.EQ.1) GOTO 210

      IF(IGROW.LE.IGMAX) THEN
        SDEDY = SDEDY+1
      ENDIF

      IF(IGROW.GT.IGMAX) THEN
        SDEDY = SDEDY+SUNSTP
      ENDIF

  210 CONTINUE

      DY     = SDEDY+1
      MAXDAY = DAYPYR+1.0E-2

      IF(SDEDY.LE.MAXDAY) GOTO 211

      SDEDY = SDEDY-MAXDAY-1
      SDEYR = SDEYR+1

  211 CONTINUE

      COSE   = COS(ANOME(DY))
      SINE   = SIN(ANOME(DY))
      RSDIST = (AORB*(1.0- ECCN*COSE))**2
      V1     = ARCOS((COSE-ECCN)/(1.-ECCN*COSE))
      V2     = ARSIN(ESQ*SINE/(1.-ECCN*COSE))
      ANOMT  = QUAD(V2,V1)
      SIND   = SIN(DECMAX)*COS(ANOMT-VINC)
      DEC    = ARSIN(SIND)
      COSD   = COS(DEC)
      ANOMTP = ANOMT-VINC+PI*0.5

      IF(ANOMTP.LT.0.) THEN
        ANOMTP = ANOMTP+2.0*PI
      ENDIF

      BETA   = ARSIN(SIN(ORBINC)*SIN(ANOMT-ANMTSP))
      ETA1   = ARCOS(COS(ANOMT-ANMTSP)/COS(BETA))
      ETA2   = ARSIN(COS(ORBINC)*SIN(ANOMT-ANMTSP)/COS(BETA))
      ETA    = QUAD(ETA2,ETA1)
      HELLON = ETA+ETAS

      IF(HELLON.GT.2.*PI) THEN
        HELLON = HELLON-2.0*PI
      ENDIF

      RADDEG = 180./PI
      VOUT   = ANOMT*RADDEG
      VPOUT  = ANOMTP*RADDEG
      ETAOUT = HELLON*RADDEG

      IF(VOUT.LT.0.) THEN
        VOUT = VOUT+360.0
      ENDIF

      IF(VPOUT.LT.0.) THEN
        VPOUT = VPOUT+360.0
      ENDIF

      IF(ETAOUT.LT.0.) THEN
        ETAOUT = ETAOUT+360.0
      ENDIF

      VOUT   = MOD(VOUT,360.0D0)
      VPOUT  = MOD(VPOUT,360.0D0)
      ETAOUT = MOD(ETAOUT,360.0D0)

      WRITE(MTP,50) VOUT, VPOUT, ETAOUT
      WRITE(MTP,51) SDEDY, SDEYR, IGROW
      WRITE(MTP,52) DEC, RSDIST

   50 FORMAT('TRUE ANAMOLY=',F15.7,3X,'LS=',F15.7,3X,
     *           'HELIOCENTRIC LONGITUDE =',F15.7)
   51 FORMAT(1X, 'DAY=',I5,5X, 'YEAR=',I3,5X, 'IGROW=',I5)
   52 FORMAT(5X, 'DEC=',E13.6,5X, 'RSDIST=',E12.6)

      RETURN
      END


      subroutine grid
c
c***********************************************************************
c     adaptive grid definition
c.......................................................................
c     called by: matgen, gridinit
c***********************************************************************
c
      include'titan.imp'
      include'titan.par'
      include'titan.com'
c
c-----------------------------------------------------------------------
c
      alpha = alph * ( 1.0D0 + alph )
      gamma = ( tau / dtime )**ibet
c
c***********************************************************************
c     lagrangean grid; equations lg1 & ag15 - ag18
c***********************************************************************
c
      if ( lgrid .eq. 3 ) then
c
             do 301 k = ngrs, ngre + 1
             rhs( ir,     k ) = (rn(k) - ro(k)) / dtime - u   (k)
             e00( ir, jr, k ) =  rn(k)          / dtime
             e00( ir, ju, k ) =                         - unom(k) * thet
  301        continue
             end if
c
c***********************************************************************
c     eulerian grid; equations eg1 & ag12 - ag14
c***********************************************************************
c
      if ( lgrid .eq. 2 ) then
c
             do 201 k = ngrs, ngre + 1
             rhs( ir,     k ) = rn(k) - ro(k)
             e00( ir, jr, k ) = rn(k)
  201        continue
             end if
c
c***********************************************************************
c     adaptive grid; equations ag1 - ag6
c***********************************************************************
c
c+++++++++ lgrid .eq. 1 +++++++++++++++++++++++++++++++++++++++++++begin
c
      if ( lgrid .eq. 1 ) then
c
c=======================================================================
c     abscissa
c=======================================================================
c-----------------------------------------------------------------------
c     linear grid concentration
c-----------------------------------------------------------------------
c
c     equations ag7 & ag19 - ag21
c
      if (ladx .eq. 1) then
           do 1 k = ngrs, ngre
           xnu     (k) =   xscale            / ( rn(k+1) - rn(k) )
           dnudlr00(k) = + xscale * rn(k  )  / ( rn(k+1) - rn(k) )**2
           dnudlrp1(k) = - xscale * rn(k+1)  / ( rn(k+1) - rn(k) )**2
           xnuo    (k) =   xscale            / ( ro(k+1) - ro(k) )
    1      continue
      end if
c
c-----------------------------------------------------------------------
c     logarithmic grid concentration
c-----------------------------------------------------------------------
c
c     equations ag8 & ag22 - ag24
c
      if (ladx .eq. 2) then
           do 2 k = ngrs, ngre
           xnu     (k) = ( rn(k+1) + rn(k) ) / ( rn(k+1) - rn(k) ) /2.D0
           dnudlr00(k) = + rn(k+1) * rn(k)   / ( rn(k+1) - rn(k) )**2
           dnudlrp1(k) = - rn(k+1) * rn(k)   / ( rn(k+1) - rn(k) )**2
           xnuo    (k) = ( ro(k+1) + ro(k) ) / ( ro(k+1) - ro(k) ) /2.D0
    2      continue
      end if
c
c-----------------------------------------------------------------------
c     spatial operator; equations ag5 & ag32, ag34 - ag37
c-----------------------------------------------------------------------
c
      do 3 k = ngrs + 1, ngre - 1
c
      xnt     (k) =                        xnu     (k) - alpha *
     .            ( xnu     (k-1) - 2.D0 * xnu     (k) + xnu     (k+1) )
c
      dntdlrm1(k) = dnudlr00(k-1)
      dntdlr00(k) = dnudlrp1(k-1) - 2.D0 * dnudlr00(k)
      dntdlrp1(k) =               - 2.D0 * dnudlrp1(k) + dnudlr00(k+1)
      dntdlrp2(k) =                                    + dnudlrp1(k+1)
c
      dntdlrm1(k) = - alpha * dntdlrm1(k)
      dntdlr00(k) = - alpha * dntdlr00(k) + dnudlr00(k)
      dntdlrp1(k) = - alpha * dntdlrp1(k) + dnudlrp1(k)
      dntdlrp2(k) = - alpha * dntdlrp2(k)
c
      xnto    (k) =                        xnuo    (k) - alpha *
     .            ( xnuo    (k-1) - 2.D0 * xnuo    (k) + xnuo    (k+1) )
c
c-----------------------------------------------------------------------
c     temporal operator; equations ag4 & ag33, ag38 - ag41
c-----------------------------------------------------------------------
c
      xnc     (k) = ( 1.0D0 + gamma ) * xnt     (k)
     .                      - gamma   * xnto    (k)
c
      dncdlrm1(k) = ( 1.0D0 + gamma ) * dntdlrm1(k)
      dncdlr00(k) = ( 1.0D0 + gamma ) * dntdlr00(k)
      dncdlrp1(k) = ( 1.0D0 + gamma ) * dntdlrp1(k)
      dncdlrp2(k) = ( 1.0D0 + gamma ) * dntdlrp2(k)
    3 continue
c
c=======================================================================
c     ordinates:
c     l = 1 => xm     l = 2 => d      l = 3 => t          l = 4 => er
c     l = 5 => pg     l = 6 => eg     l = 7 => chi        l = 8 => qx
c     l = 9 => fr     l =10 => bri
c=======================================================================
c-----------------------------------------------------------------------
c     initialization
c-----------------------------------------------------------------------
c
      do 4 k = 1, mgr
      ss(k) = 0.0D0
    4 continue
c
      do 8 m = 1, meqn
      do 5 k = 1, mgr
      dssdlx00(k, m) = 0.0D0
      dssdlxp1(k, m) = 0.0D0
      dssdlxp2(k, m) = 0.0D0
    5 continue
c
      do 7 l = 1, mad
      do 6 k = 1, mgr
       cs     (k, l   ) = 0.0D0
      dcsdlx00(k, l, m) = 0.0D0
      dcsdlxp1(k, l, m) = 0.0D0
      dcsdlxp2(k, l, m) = 0.0D0
    6 continue
    7 continue
    8 continue
c
c-----------------------------------------------------------------------
c     linear resolution
c-----------------------------------------------------------------------
c.......................................................................
c     mass; equations ag59 - ag61
c.......................................................................
c
      if (wt(1) .gt. 0.0D0 .and. lady(1) .eq. 1 .or.
     .    wt(11).gt. 0.0D0 .and. lady(11).eq. 1 ) then
            l = 1
            do 11 k = ngrs, ngre - 1
             cs     (k,l   ) = ( xmen(k+1) - xmen(k) ) / yscl(l)
            dcsdlx00(k,l,im) = (           - xmen(k) ) / yscl(l)
            dcsdlxp1(k,l,im) = ( xmen(k+1)           ) / yscl(l)
   11       continue
      end if
c
c.......................................................................
c     density; equations ag62 - ag64
c.......................................................................
c
      if (wt(2) .gt. 0.0D0 .and. lady(2) .eq. 1) then
            l = 2
            do 12 k = ngrs, ngre - 1
             cs     (k,l   ) = ( dn(k+1) - dn(k) ) / yscl(l)
            dcsdlx00(k,l,id) = (         - dn(k) ) / yscl(l)
            dcsdlxp1(k,l,id) = ( dn(k+1)         ) / yscl(l)
   12       continue
      end if
c
c.......................................................................
c     gas temperature; equations ag65 - ag67
c.......................................................................
c
      if (wt(3) .gt. 0.0D0 .and. lady(3) .eq. 1) then
            l = 3
            do 13 k = ngrs, ngre - 1
             cs     (k,l   ) = ( tn(k+1) - tn(k) ) / yscl(l)
            dcsdlx00(k,l,it) = (         - tn(k) ) / yscl(l)
            dcsdlxp1(k,l,it) = ( tn(k+1)         ) / yscl(l)
   13       continue
      end if
c
c.......................................................................
c     radiation energy; equations ag68 - ag70
c.......................................................................
c
      if (wt(4) .gt. 0.0D0 .and. lady(4) .eq. 1) then
            l = 4
            do 14 k = ngrs, ngre - 1
             cs     (k,l   ) = ( ern(k+1) - ern(k) ) / yscl(l)
            dcsdlx00(k,l,ie) = (          - ern(k) ) / yscl(l)
            dcsdlxp1(k,l,ie) = ( ern(k+1)          ) / yscl(l)
   14       continue
      end if
c
c.......................................................................
c     gas pressure; equations ag71 - ag75
c.......................................................................
c
      if (wt(5) .gt. 0.0D0 .and. lady(5) .eq. 1) then
            l = 5
            do 15 k = ngrs, ngre - 1
             cs     (k,l   ) = ( pgn(k+1) -   pgn   (k  )) / yscl(l)
            dcsdlx00(k,l,id) = - pgn(k  ) * dlpgdldn(k  )  / yscl(l)
            dcsdlxp1(k,l,id) = + pgn(k+1) * dlpgdldn(k+1)  / yscl(l)
            dcsdlx00(k,l,it) = - pgn(k  ) * dlpgdltn(k  )  / yscl(l)
            dcsdlxp1(k,l,it) = + pgn(k+1) * dlpgdltn(k+1)  / yscl(l)
   15       continue
      end if
c
c.......................................................................
c     gas energy density; equations ag76 - ag80
c.......................................................................
c
      if (wt(6) .gt. 0.0D0 .and. lady(6) .eq. 1) then
            l = 6
            do 16 k = ngrs, ngre - 1
             cs     (k,l   ) = ( egn(k+1) -   egn   (k  )) / yscl(l)
            dcsdlx00(k,l,id) = - egn(k  ) * dlegdldn(k  )  / yscl(l)
            dcsdlxp1(k,l,id) = + egn(k+1) * dlegdldn(k+1)  / yscl(l)
            dcsdlx00(k,l,it) = - egn(k  ) * dlegdltn(k  )  / yscl(l)
            dcsdlxp1(k,l,it) = + egn(k+1) * dlegdltn(k+1)  / yscl(l)
   16       continue
      end if
c
c.......................................................................
c     opacity; equations ag81 - ag85
c.......................................................................
c
      if (wt(7) .gt. 0.0D0 .and. lady(7) .eq. 1) then
            l = 7
            do 17 k = ngrs, ngre - 1
             cs     (k,l   ) = ( chifn(k+1) -   chifn (k  )) / yscl(l)
            dcsdlx00(k,l,id) = - chifn(k  ) * dlcfdldn(k  )  / yscl(l)
            dcsdlxp1(k,l,id) = + chifn(k+1) * dlcfdldn(k+1)  / yscl(l)
            dcsdlx00(k,l,it) = - chifn(k  ) * dlcfdltn(k  )  / yscl(l)
            dcsdlxp1(k,l,it) = + chifn(k+1) * dlcfdltn(k+1)  / yscl(l)
   17       continue
      end if
c
c.......................................................................
c     viscosity; equations ag99 - ag109
c.......................................................................
c
      if (wt(8) .gt. 0.0D0 .and. lady(8) .eq. 1) then
            l = 8
            do 18 k = ngrs, ngre - 1
             cs     (k,l   ) = ( qx     (k+1) -  qx     (k  )) / yscl(l)
            dcsdlx00(k,l,ir) =                - dqxdlr00(k  )  / yscl(l)
            dcsdlxp1(k,l,ir) = (dqxdlr00(k+1) - dqxdlrp1(k  )) / yscl(l)
            dcsdlxp2(k,l,ir) =  dqxdlrp1(k+1)                  / yscl(l)
            dcsdlx00(k,l,iu) =                - dqxdlu00(k  )  / yscl(l)
            dcsdlxp1(k,l,iu) = (dqxdlu00(k+1) - dqxdlup1(k  )) / yscl(l)
            dcsdlxp2(k,l,iu) =  dqxdlup1(k+1)                  / yscl(l)
            dcsdlx00(k,l,id) =                - dqxdld00(k  )  / yscl(l)
            dcsdlxp1(k,l,id) =  dqxdld00(k+1)                  / yscl(l)
            dcsdlx00(k,l,it) =                - dqxdlt00(k  )  / yscl(l)
            dcsdlxp1(k,l,it) =  dqxdlt00(k+1)                  / yscl(l)
   18       continue
      end if
c
c.......................................................................
c     radiation flux
c.......................................................................
c
      if (wt(9) .gt. 0.0D0 .and. lady(9) .eq. 1) then
            l = 9
            do 19 k = ngrs, ngre - 1
             cs     (k,l   ) = ( frn(k+1) - frn(k) ) / yscl(l)
            dcsdlx00(k,l,if) = (          - frn(k) ) / yscl(l)
            dcsdlxp1(k,l,if) = ( frn(k+1)          ) / yscl(l)
   19       continue
      end if
c
c.......................................................................
c     luminosity or velocity
c.......................................................................
c
      if (wt(10) .gt. 0.0D0 .and. lady(10) .eq. 1) then
            l = 10
            do 20 k = ngrs, ngre - 1
             cs     (k,l   ) = ( bri(k+1) - bri(k) ) / yscl(l)
            dcsdlx00(k,l,jb) = (          - bri(k) ) / yscl(l)
            dcsdlxp1(k,l,jb) = ( bri(k+1)          ) / yscl(l)
   20       continue
      end if
c
c
c-----------------------------------------------------------------------
c     logarithmic resolution
c-----------------------------------------------------------------------
c.......................................................................
c     interior mass; equations ag110 - ag112
c.......................................................................
c
      if( wt(1) .gt. 0.0D0 .and. lady(1) .eq. 2 ) then
            l = 1
                                     xmscl = yscl(1)
            do 21 k = ngrs, ngre - 1
             cs     (k,l   ) =               ( xmen(k+1) - xmen(k) )
     .                       /( 2.D0*xmscl - ( xmen(k+1) + xmen(k) ))
            dcsdlx00(k,l,im) =  2.D0*xmen(k)*( xmen(k+1) - xmscl)
     .                       /( 2.D0*xmscl - ( xmen(k+1) + xmen(k) ))**2
            dcsdlxp1(k,l,im) =  2.D0*xmen(k+1) * ( xmscl - xmen(k) )
     .                       /( 2.D0*xmscl - ( xmen(k+1) + xmen(k) ))**2
   21       continue
      end if
c
c.......................................................................
c     exterior mass; equations ag110 - ag112
c.......................................................................
c
      if( wt(11) .gt. 0.0D0 .and. lady(11) .eq. 2 ) then
            l = 11
            do 210 k = ngrs, ngre - 1
             cs     (k,l   ) =             ( xmen(k+1) - xmen(k) )
     .                                   / ( xmen(k+1) + xmen(k) )
            dcsdlx00(k,l,im) =             - xmen(k+1) * xmen(k)  * 2.D0
     .                                   / ( xmen(k+1) + xmen(k) )**2
            dcsdlxp1(k,l,im) =             + xmen(k+1) * xmen(k)  * 2.D0
     .                                   / ( xmen(k+1) + xmen(k) )**2
  210       continue
      end if
c
c.......................................................................
c     density; equations ag113 - ag115
c.......................................................................
c
      if (wt(2) .gt. 0.0D0 .and. lady(2) .eq. 2) then
            l = 2
            do 22 k = ngrs, ngre - 1
             cs     (k,l   ) =               ( dn(k+1) - dn(k) )
     .                                     / ( dn(k+1) + dn(k) )
            dcsdlx00(k,l,id) =               - dn(k+1) * dn(k)  * 2.D0
     .                                     / ( dn(k+1) + dn(k) )**2
            dcsdlxp1(k,l,id) =               + dn(k+1) * dn(k)  * 2.D0
     .                                     / ( dn(k+1) + dn(k) )**2
   22       continue
      end if
c
c.......................................................................
c     gas temperature; equations ag116 - ag118
c.......................................................................
c
      if (wt(3) .gt. 0.0D0 .and. lady(3) .eq. 2) then
            l = 3
            do 23 k = ngrs, ngre - 1
             cs     (k,l   ) =               ( tn(k+1) - tn(k) )
     .                                     / ( tn(k+1) + tn(k) )
            dcsdlx00(k,l,it) =               - tn(k+1) * tn(k)  * 2.D0
     .                                     / ( tn(k+1) + tn(k) )**2
            dcsdlxp1(k,l,it) =               + tn(k+1) * tn(k)  * 2.D0
     .                                     / ( tn(k+1) + tn(k) )**2
   23       continue
      end if
c
c.......................................................................
c     radiation energy; equations ag119 - ag121
c.......................................................................
c
      if (wt(4) .gt. 0.0D0 .and. lady(4) .eq. 2) then
            l = 4
            do 24 k = ngrs, ngre - 1
             cs     (k,l   ) =               ( ern(k+1) - ern(k) )
     .                                     / ( ern(k+1) + ern(k) )
            dcsdlx00(k,l,ie) =               - ern(k+1) * ern(k)  * 2.D0
     .                                     / ( ern(k+1) + ern(k) )**2
            dcsdlxp1(k,l,ie) =               + ern(k+1) * ern(k)  * 2.D0
     .                                     / ( ern(k+1) + ern(k) )**2
   24       continue
      end if
c
c.......................................................................
c     gas pressure; equations ag122 - ag126
c.......................................................................
c
      if (wt(5) .gt. 0.0D0 .and. lady(5) .eq. 2) then
            l = 5
            do 25 k = ngrs, ngre - 1
             cs     (k,l   ) =               ( pgn(k+1) - pgn(k) )
     .                                     / ( pgn(k+1) + pgn(k) )
            dcsdlx00(k,l,it) =               - pgn(k+1) * pgn(k)  * 2.D0
     .                     * dlpgdltn(k  ) / ( pgn(k+1) + pgn(k) )**2
            dcsdlxp1(k,l,it) =               + pgn(k+1) * pgn(k)  * 2.D0
     .                     * dlpgdltn(k+1) / ( pgn(k+1) + pgn(k) )**2
            dcsdlx00(k,l,id) =               - pgn(k+1) * pgn(k)  * 2.D0
     .                     * dlpgdldn(k  ) / ( pgn(k+1) + pgn(k) )**2
            dcsdlxp1(k,l,id) =               + pgn(k+1) * pgn(k)  * 2.D0
     .                     * dlpgdldn(k+1) / ( pgn(k+1) + pgn(k) )**2
   25       continue
      end if
c
c.......................................................................
c     gas energy density; equations ag127 - ag131
c.......................................................................
c
      if (wt(6) .gt. 0.0D0 .and. lady(6) .eq. 2) then
            l = 6
            do 26 k = ngrs, ngre - 1
             cs     (k,l   ) =               ( egn(k+1) - egn(k) )
     .                                     / ( egn(k+1) + egn(k) )
            dcsdlx00(k,l,it) =               - egn(k+1) * egn(k)  * 2.D0
     .                     * dlegdltn(k  ) / ( egn(k+1) + egn(k) )**2
            dcsdlxp1(k,l,it) =               + egn(k+1) * egn(k)  * 2.D0
     .                     * dlegdltn(k+1) / ( egn(k+1) + egn(k) )**2
            dcsdlx00(k,l,id) =               - egn(k+1) * egn(k)  * 2.D0
     .                     * dlegdldn(k  ) / ( egn(k+1) + egn(k) )**2
            dcsdlxp1(k,l,id) =               + egn(k+1) * egn(k)  * 2.D0
     .                     * dlegdldn(k+1) / ( egn(k+1) + egn(k) )**2
   26       continue
      end if
c
c.......................................................................
c     opacity; equations ag132 - ag136
c.......................................................................
c
      if (wt(7) .gt. 0.0D0 .and. lady(7) .eq. 2) then
            l = 7
            do 27 k = ngrs, ngre - 1
             cs     (k,l   ) =           ( chifn(k+1) - chifn(k) )
     .                                 / ( chifn(k+1) + chifn(k) )
            dcsdlx00(k,l,it) =           - chifn(k+1) * chifn(k)  * 2.D0
     .                 * dlcfdltn(k  ) / ( chifn(k+1) + chifn(k) )**2
            dcsdlxp1(k,l,it) =           + chifn(k+1) * chifn(k)  * 2.D0
     .                 * dlcfdltn(k+1) / ( chifn(k+1) + chifn(k) )**2
            dcsdlx00(k,l,id) =           - chifn(k+1) * chifn(k)  * 2.D0
     .                 * dlcfdldn(k  ) / ( chifn(k+1) + chifn(k) )**2
            dcsdlxp1(k,l,id) =           + chifn(k+1) * chifn(k)  * 2.D0
     .                 * dlcfdldn(k+1) / ( chifn(k+1) + chifn(k) )**2
   27       continue
      end if
c
c.......................................................................
c     viscosity; equations ag137 - ag147
c.......................................................................
c
      if (wt(8) .gt. 0.0D0 .and. lady(8) .eq. 2) then
            l = 8
            do 28 k = ngrs, ngre - 1
             cs     (k,l   ) =                      (qx(k+1) - qx(k))
     .                                            / (qx(k+1) + qx(k))
            dcsdlx00(k,l,ir) = -2.D0*dqxdlr00(k  ) * qx(k+1)
     .                                            / (qx(k+1) + qx(k))**2
            dcsdlxp1(k,l,ir) =  2.D0*dqxdlr00(k+1) *           qx(k)
     .                                            / (qx(k+1) + qx(k))**2
     .                         -2.D0*dqxdlrp1(k  ) * qx(k+1)
     .                                            / (qx(k+1) + qx(k))**2
            dcsdlxp2(k,l,ir) =  2.D0*dqxdlrp1(k+1) *           qx(k)
     .                                            / (qx(k+1) + qx(k))**2
            dcsdlx00(k,l,iu) =  2.D0*dqxdlu00(k  ) * qx(k+1)
     .                                            / (qx(k+1) + qx(k))**2
            dcsdlxp1(k,l,iu) =  2.D0*dqxdlu00(k+1) *           qx(k)
     .                                            / (qx(k+1) + qx(k))**2
     .                         -2.D0*dqxdlup1(k  ) * qx(k+1)
     .                                            / (qx(k+1) + qx(k))**2
            dcsdlxp2(k,l,iu) =  2.D0*dqxdlup1(k+1) *           qx(k)
     .                                            / (qx(k+1) + qx(k))**2
            dcsdlx00(k,l,id) = -2.D0*dqxdld00(k  ) * qx(k+1)
     .                                            / (qx(k+1) + qx(k))**2
            dcsdlxp1(k,l,id) =  2.D0*dqxdld00(k+1) *           qx(k)
     .                                            / (qx(k+1) + qx(k))**2
            dcsdlx00(k,l,it) = -2.D0*dqxdlt00(k  ) * qx(k+1)
     .                                            / (qx(k+1) + qx(k))**2
            dcsdlxp1(k,l,it) =  2.D0*dqxdlt00(k+1) *           qx(k)
     .                                            / (qx(k+1) + qx(k))**2
   28       continue
      end if
c
c.......................................................................
c     radiative flux
c.......................................................................
c
      if (wt(9) .gt. 0.0D0 .and. lady(9) .eq. 2) then
            l = 9
            do 29 k = ngrs, ngre - 1
             cs     (k,l   ) =               ( frn(k+1) - frn(k) )
     .                                     / ( frn(k+1) + frn(k) )
            dcsdlx00(k,l,if) =               - frn(k+1) * frn(k)  * 2.D0
     .                                     / ( frn(k+1) + frn(k) )**2
            dcsdlxp1(k,l,if) =               + frn(k+1) * frn(k)  * 2.D0
     .                                     / ( frn(k+1) + frn(k) )**2
   29       continue
      end if
c
c.......................................................................
c     luminosity or velocity
c.......................................................................
c
      if (wt(10) .gt. 0.0D0 .and. lady(10) .eq. 2) then
            l = 10
            do 30 k = ngrs, ngre - 1
             cs     (k,l   ) =               ( bri(k+1) - bri(k) )
     .                                     / ( bri(k+1) + bri(k) )
            dcsdlx00(k,l,jb) =               - bri(k+1) * bri(k)  * 2.D0
     .                                     / ( bri(k+1) + bri(k) )**2
            dcsdlxp1(k,l,jb) =               + bri(k+1) * bri(k)  * 2.D0
     .                                     / ( bri(k+1) + bri(k) )**2
   30       continue
      end if
c
c-----------------------------------------------------------------------
c     harmonic resolution
c-----------------------------------------------------------------------
c.......................................................................
c     interior mass; equations ag148 - ag150
c.......................................................................
c
      if (wt(1) .gt. 0.0D0 .and. lady(1) .eq. 3) then
            l = 1
                              xmscl = yscl(1)
            do 31 k = ngrs, ngre - 1
            cs     (k,l   ) =
     .                       (xmscl - xmen(k+1)) / (xmscl - xmen(k  ))
     .                     - (xmscl - xmen(k  )) / (xmscl - xmen(k+1))
           dcsdlx00(k,l,im) =       ( xmen(k  )  / (xmscl - xmen(k  )) )
     .                   * ( (xmscl - xmen(k+1)) / (xmscl - xmen(k  ))
     .                     + (xmscl - xmen(k  )) / (xmscl - xmen(k+1)) )
           dcsdlxp1(k,l,im) =     - ( xmen(k+1)  / (xmscl - xmen(k+1)) )
     .                   * ( (xmscl - xmen(k+1)) / (xmscl - xmen(k  ))
     .                     + (xmscl - xmen(k  )) / (xmscl - xmen(k+1)) )

   31       continue
      end if
c.......................................................................
c     exterior mass; equations ag148 - ag150
c.......................................................................
c
      if (wt(11) .gt. 0.0D0 .and. lady(11) .eq. 3) then
            l = 11
            do 310 k = ngrs, ngre - 1
             cs     (k,l   ) =   xmen(k+1)/xmen(k) - xmen(k)/xmen(k+1)
            dcsdlx00(k,l,im) = - xmen(k+1)/xmen(k) - xmen(k)/xmen(k+1)
            dcsdlxp1(k,l,im) =   xmen(k+1)/xmen(k) + xmen(k)/xmen(k+1)
  310       continue
      end if
c
c
c.......................................................................
c     density; equations ag151 - ag153
c.......................................................................
c
      if (wt(2) .gt. 0.0D0 .and. lady(2) .eq. 3) then
            l = 2
            do 32 k = ngrs, ngre - 1
             cs     (k,l   ) =   dn(k+1) / dn(k) - dn(k) / dn(k+1)
            dcsdlx00(k,l,id) = - dn(k+1) / dn(k) - dn(k) / dn(k+1)
            dcsdlxp1(k,l,id) =   dn(k+1) / dn(k) + dn(k) / dn(k+1)
   32       continue
      end if
c
c.......................................................................
c     temperature; equations ag154 - ag156
c.......................................................................
c
      if (wt(3) .gt. 0.0D0 .and. lady(3) .eq. 3) then
            l = 3
            do 33 k = ngrs, ngre - 1
             cs     (k,l   ) =   tn(k+1) / tn(k) - tn(k) / tn(k+1)
            dcsdlx00(k,l,it) = - tn(k+1) / tn(k) - tn(k) / tn(k+1)
            dcsdlxp1(k,l,it) =   tn(k+1) / tn(k) + tn(k) / tn(k+1)
   33       continue
      end if
c
c.......................................................................
c     radiation energy density; equations ag157 - ag159
c.......................................................................
c
      if (wt(4) .gt. 0.0D0 .and. lady(4) .eq. 3) then
            l = 4
            do 34 k = ngrs, ngre - 1
             cs     (k,l   ) =   ern(k+1) / ern(k) - ern(k) / ern(k+1)
            dcsdlx00(k,l,ie) = - ern(k+1) / ern(k) - ern(k) / ern(k+1)
            dcsdlxp1(k,l,ie) =   ern(k+1) / ern(k) + ern(k) / ern(k+1)
   34       continue
      end if
c
c.......................................................................
c     gas pressure; equations ag160 - ag164
c.......................................................................
c
      if (wt(5) .gt. 0.0D0 .and. lady(5) .eq. 3) then
            l = 5
            do 35 k = ngrs, ngre - 1
             cs     (k,l   ) =     pgn(k+1)/pgn(k) - pgn(k)/pgn(k+1)
c
            dcsdlx00(k,l,id) =
     .         - dlpgdldn(k  ) * ( pgn(k+1)/pgn(k) + pgn(k)/pgn(k+1) )
c
            dcsdlxp1(k,l,id) =
     .           dlpgdldn(k+1) * ( pgn(k+1)/pgn(k) + pgn(k)/pgn(k+1) )
c
            dcsdlx00(k,l,it) =
     .         - dlpgdltn(k  ) * ( pgn(k+1)/pgn(k) + pgn(k)/pgn(k+1) )
c
            dcsdlxp1(k,l,it) =
     .           dlpgdltn(k+1) * ( pgn(k+1)/pgn(k) + pgn(k)/pgn(k+1) )
   35       continue
      end if
c
c.......................................................................
c     gas energy density; equations ag165 - ag169
c.......................................................................
c
      if (wt(6) .gt. 0.0D0 .and. lady(6) .eq. 3) then
            l = 6
            do 36 k = ngrs, ngre - 1
             cs     (k,l   ) =     egn(k+1)/egn(k) - egn(k)/egn(k+1)
c
            dcsdlx00(k,l,id) =
     .         - dlegdldn(k  ) * ( egn(k+1)/egn(k) + egn(k)/egn(k+1) )
c
            dcsdlxp1(k,l,id) =
     .           dlegdldn(k+1) * ( egn(k+1)/egn(k) + egn(k)/egn(k+1) )
c
            dcsdlx00(k,l,it) =
     .         - dlegdltn(k  ) * ( egn(k+1)/egn(k) + egn(k)/egn(k+1) )
c
            dcsdlxp1(k,l,it) =
     .           dlegdltn(k+1) * ( egn(k+1)/egn(k) + egn(k)/egn(k+1) )
   36       continue
      end if
c
c.......................................................................
c     opacity; equations ag170 - ag174
c.......................................................................
c
      if (wt(7) .gt. 0.0D0 .and. lady(7) .eq. 3) then
        l = 7
        do 37 k = ngrs, ngre - 1
        cs     (k,l   ) =   chifn(k+1)/chifn(k) - chifn(k)/chifn(k+1)
c
       dcsdlx00(k,l,id) =
     .   - dlcfdldn(k  ) * (chifn(k+1)/chifn(k) + chifn(k)/chifn(k+1))
c
       dcsdlxp1(k,l,id) =
     .     dlcfdldn(k+1) * (chifn(k+1)/chifn(k) + chifn(k)/chifn(k+1))
c
       dcsdlx00(k,l,it) =
     .   - dlcfdltn(k  ) * (chifn(k+1)/chifn(k) + chifn(k)/chifn(k+1))
c
       dcsdlxp1(k,l,it) =
     .     dlcfdltn(k+1) * (chifn(k+1)/chifn(k) + chifn(k)/chifn(k+1))
   37       continue
      end if
c
c.......................................................................
c     viscosity; equations ag175 - ag185
c.......................................................................
c
      if (wt(8) .gt. 0.0D0 .and. lady(8) .eq. 3) then
           l = 8
          do 38 k = ngrs, ngre - 1
           cs     (k,l   ) =           (qx(k+1)/qx(k) - qx(k)/qx(k+1))
c
          dcsdlx00(k,l,ir) =
     .     - (dqxdlr00(k  )/qx(k  )) * (qx(k+1)/qx(k) + qx(k)/qx(k+1))
c
          dcsdlxp1(k,l,ir) =
     .       (dqxdlr00(k+1)/qx(k+1)) * (qx(k+1)/qx(k) + qx(k)/qx(k+1))
     .     - (dqxdlrp1(k  )/qx(k  )) * (qx(k+1)/qx(k) + qx(k)/qx(k+1))
c
          dcsdlxp2(k,l,ir) =
     .       (dqxdlrp1(k+1)/qx(k+1)) * (qx(k+1)/qx(k) + qx(k)/qx(k+1))
c
          dcsdlx00(k,l,id) =
     .    - (dqxdld00(k  )/qx(k  )) *  (qx(k+1)/qx(k) + qx(k)/qx(k+1))
c
          dcsdlxp1(k,l,id) =
     .       (dqxdld00(k+1)/qx(k+1)) * (qx(k+1)/qx(k) + qx(k)/qx(k+1))
c
          dcsdlx00(k,l,iu) =
     .     - (dqxdlu00(k  )/qx(k+1)) * (qx(k+1)/qx(k) + qx(k)/qx(k+1))
c
          dcsdlxp1(k,l,iu) =
     .       (dqxdlu00(k+1)/qx(k+1)) * (qx(k+1)/qx(k) + qx(k)/qx(k+1))
     .     - (dqxdlup1(k  )/qx(k  )) * (qx(k+1)/qx(k) + qx(k)/qx(k+1))
c
          dcsdlxp2(k,l,iu) =
     .       (dqxdlup1(k+1)/qx(k+1)) * (qx(k+1)/qx(k) + qx(k)/qx(k+1))
c
          dcsdlx00(k,l,it) =
     .     - (dqxdlt00(k  )/qx(k  )) * (qx(k+1)/qx(k) + qx(k)/qx(k+1))
c
          dcsdlxp1(k,l,it) =
     .       (dqxdlt00(k+1)/qx(k+1)) * (qx(k+1)/qx(k) + qx(k)/qx(k+1))
   38     continue
      end if
c
c.......................................................................
c     radiative flux
c.......................................................................
c
      if (wt(9) .gt. 0.0D0 .and. lady(9) .eq. 3) then
            l = 9
            do 39 k = ngrs, ngre - 1
             cs     (k,l   ) =   frn(k+1) / frn(k) - frn(k) / frn(k+1)
            dcsdlx00(k,l,if) = - frn(k+1) / frn(k) - frn(k) / frn(k+1)
            dcsdlxp1(k,l,if) =   frn(k+1) / frn(k) + frn(k) / frn(k+1)
   39       continue
      end if
c
c.......................................................................
c     luminosity or velocity
c.......................................................................
c
      if (wt(10) .gt. 0.0D0 .and. lady(10) .eq. 3) then
            l = 10
            do 40 k = ngrs, ngre - 1
             cs     (k,l   ) =   bri(k+1) / bri(k) - bri(k) / bri(k+1)
            dcsdlx00(k,l,jb) = - bri(k+1) / bri(k) - bri(k) / bri(k+1)
            dcsdlxp1(k,l,jb) =   bri(k+1) / bri(k) + bri(k) / bri(k+1)
   40       continue
      end if
c
c=======================================================================
c     sums and derivatives
c=======================================================================
c
c     equation ag42
c
      do 43  l = 1, mad
      if (wt(l) .gt. 0.0D0) then
            do 50 k  = ngrs, ngre - 1
            ss   (k) = ss(k) + wt(l) * cs(k,l)**2
   50       continue
c
c     equations ag186 - ag188
c
            do 42 m = 1, meqn
            do 41 k = ngrs, ngre - 1
            dssdlx00(k,m) = dssdlx00(k,m) + 2.0D0 *  cs     (k,l)
     .                                    * wt(l) * dcsdlx00(k,l,m)
            dssdlxp1(k,m) = dssdlxp1(k,m) + 2.0D0 *  cs     (k,l)
     .                                    * wt(l) * dcsdlxp1(k,l,m)
            dssdlxp2(k,m) = dssdlxp2(k,m) + 2.0D0 *  cs     (k,l)
     .                                    * wt(l) * dcsdlxp2(k,l,m)
   41       continue
   42       continue
      end if
   43 continue
c
      do 44 k = ngrs + 1, ngre - 1
c
c     equation ag43
c
      rr(k) = sqrt( 1.0D0 + xnu(k)**2 * ss(k) )
c
c     equations  ag44 - ag47
c
      dabdlrm1(k) =    dncdlrm1(k) / rr(k)
      dabdlr00(k) =    dncdlr00(k) / rr(k)
     .              - (dnudlr00(k) / rr(k)**3) * xnc(k)*xnu(k)*ss(k)
      dabdlrp1(k) =    dncdlrp1(k) / rr(k)
     .              - (dnudlrp1(k) / rr(k)**3) * xnc(k)*xnu(k)*ss(k)
      dabdlrp2(k) =    dncdlrp2(k) / rr(k)
   44 continue
c
      do 45 m = 1, meqn
      do 46 k = ngrs + 1, ngre - 1
c
c     equations ag189 - ag191
c
      dcddlx00(k,m) = 0.5D0 * dssdlx00(k,m) * xnc(k)*xnu(k)**2/rr(k)**3
      dcddlxp1(k,m) = 0.5D0 * dssdlxp1(k,m) * xnc(k)*xnu(k)**2/rr(k)**3
      dcddlxp2(k,m) = 0.5D0 * dssdlxp2(k,m) * xnc(k)*xnu(k)**2/rr(k)**3
   46 continue
   45 continue
c
c=======================================================================
c     matrix elements
c=======================================================================
c
      k = ngrs + 1
c
c     equations ag25 - ag28
c
      rhs(ir,     k) = xnu(k) - xnu(k-1)
c
      em1(ir, jr, k) = em1(ir, jr, k) - dnudlr00(k-1)
      e00(ir, jr, k) = e00(ir, jr, k) - dnudlrp1(k-1) + dnudlr00(k)
      ep1(ir, jr, k) = ep1(ir, jr, k)                 + dnudlrp1(k)
c
c     equations ag29 & ag48 - ag52
c
      do 47 k = ngrs + 2, ngre - 1
      rhs(ir,     k) = xnc(k) / rr(k) - xnc(k-1) / rr(k-1)
c
      em2(ir, jr, k) = em2(ir, jr, k) - dabdlrm1(k-1)
      em1(ir, jr, k) = em1(ir, jr, k) - dabdlr00(k-1) + dabdlrm1(k)
      e00(ir, jr, k) = e00(ir, jr, k) - dabdlrp1(k-1) + dabdlr00(k)
      ep1(ir, jr, k) = ep1(ir, jr, k) - dabdlrp2(k-1) + dabdlrp1(k)
      ep2(ir, jr, k) = ep2(ir, jr, k)                 + dabdlrp2(k)
   47 continue
c
c     equations ag192 - ag215
c
      do 48 m = 1, meqn
      do 49 k = ngrs + 2, ngre - 1
      em1(ir, m, k) = em1(ir, m, k) + dcddlx00(k-1, m)
      e00(ir, m, k) = e00(ir, m, k) + dcddlxp1(k-1, m) - dcddlx00(k, m)
      ep1(ir, m, k) = ep1(ir, m, k) + dcddlxp2(k-1, m) - dcddlxp1(k, m)
      ep2(ir, m, k) = ep2(ir, m, k)                    - dcddlxp2(k, m)
   49 continue
   48 continue
c
      k = ngre
c
c     equations ag25 - ag28
c
      rhs(ir,     k) = xnu(k) - xnu(k-1)
c
      em1(ir, jr, k) = em1(ir, jr, k) - dnudlr00(k-1)
      e00(ir, jr, k) = e00(ir, jr, k) - dnudlrp1(k-1) + dnudlr00(k)
      ep1(ir, jr, k) = ep1(ir, jr, k)                 + dnudlrp1(k)
c
c=======================================================================
c     adaptive grid boundary conditions
c=======================================================================
c
      k = ngrs
c
c-----------------------------------------------------------------------
c     eulerian inner boundary; equation bc13
c-----------------------------------------------------------------------
c
      if (leibc .gt. 0) then
            rhs(ir,     k) = rn(k) - ro(k)
            e00(ir, jr, k) = rn(k)
      end if
c
c-----------------------------------------------------------------------
c     lagrangean inner boundary; equation bc64
c-----------------------------------------------------------------------
c
      if (llibc .eq. 1) then
	    rhs(ir,     k) = (rn(k) - ro(k)) / dtime - u   (k)
	    e00(ir, jr, k) =  rn(k)          / dtime
            e00(ir, ju, k) =                         - unom(k) * thet
      end if
c
      k = ngre + 1
c
c-----------------------------------------------------------------------
c     eulerian outer boundary; equation bc26
c-----------------------------------------------------------------------
c
      if (leobc .gt. 0) then
            rhs(ir,     k) = rn(k) - ro(k)
            e00(ir, jr, k) = rn(k)
      end if
c
c-----------------------------------------------------------------------
c     lagrangean outer boundary; equation bc67
c-----------------------------------------------------------------------
c
      if (llobc .gt. 0) then
	    rhs(ir,     k) = (rn(k) - ro(k)) / dtime - u   (k)
	    e00(ir, jr, k) =  rn(k)          / dtime
            e00(ir, ju, k) =                         - unom(k) * thet
      end if
c
c+++++++++ lgrid .eq. 1 ++++++++++++++++++++++++++++++++++++++++++++ end
c
      end if
c
c=======================================================================
c     general boundary conditions
c=======================================================================
c
      k = ngrs - 1
c
c-----------------------------------------------------------------------
c     eulerian inner boundary
c-----------------------------------------------------------------------
c
c     zero flux; equation pz1 & pz2
c
      if (leibc .eq. 1) then
           rhs(ir,     k) = rn(k) - 2.0D0 * rn(k+1) + rn(k+2)
           ep2(ir, jr, k) =                           rn(k+2)
           ep1(ir, jr, k) =       - 2.0D0 * rn(k+1)
           e00(ir, jr, k) = rn(k)
      end if
c
c     nonzero flux; equation pz11 & pz12
c
      if (leibc .eq. 2) then
	    rhs(ir,     k) = rn(k) - rn(k+1) + delrl
	    ep1(ir, jr, k) =       - rn(k+1)
	    e00(ir, jr, k) = rn(k)
      end if
c
c-----------------------------------------------------------------------
c     lagrangean inner boundary
c-----------------------------------------------------------------------
c
c     equation pz21 & pz22
c
      if (llibc .eq. 1) then
        rhs(ir,     k) =
     .                 - delml/dn(k) + (rmup1n(k+1) - rmup1n(k)) / xmup1
        e00(ir, jr, k) =                            - rmup1n(k)
        ep1(ir, jr, k) =                rmup1n(k+1)
        e00(ir, jd, k) = delml/dn(k)
      end if
c
      k = ngre + 2
c
c-----------------------------------------------------------------------
c     eulerian outer boundary
c-----------------------------------------------------------------------
c
c     zero flux; equations pz39 & pz40
c
      if (leobc .eq. 1) then
            rhs(ir,     k) = rn(k) - 2.0D0 * rn(k-1) + rn(k-2)
            e00(ir, jr, k) = rn(k)
            em1(ir, jr, k) =       - 2.0D0 * rn(k-1)
            em2(ir, jr, k) =                           rn(k-2)
      end if
c
c     nonzero flux; equations pz49 & pz50
c
      if (leobc .eq. 2) then
	    rhs(ir,     k) = rn(k) - rn(k-1) - delrr
	    e00(ir, jr, k) = rn(k)
	    em1(ir, jr, k) =       - rn(k-1)
      end if
c
c     transmitting; equations pz59 & pz60
c
      if (leobc .eq. 3) then
	    rhs(ir,     k) = rn(k) - rn(k-1) - delrr
	    e00(ir, jr, k) = rn(k)
	    em1(ir, jr, k) =       - rn(k-1)
      end if
c
c-----------------------------------------------------------------------
c     lagrangean outer boundary
c-----------------------------------------------------------------------
c
c     equation pz69 & pz70
c
      if (llobc .gt. 0) then
	rhs(ir,     k) =
     .                  -delmr/dn(k-1) + (rmup1n(k) - rmup1n(k-1))/xmup1
	em1(ir, jr, k) =                            - rmup1n(k-1)
	e00(ir, jr, k) =                  rmup1n(k)
	em1(ir, jd, k) = delmr/dn(k-1)
      end if
c
c=======================================================================
c     phantom zones
c=======================================================================
c
      do 60 k = 1, ngrs - 2
      rhs(ir,     k) = 0.0D0
      e00(ir, jr, k) = 1.0D0
      ep2(ir, jr, k) = 0.0D0
      ep1(ir, jr, k) = 0.0D0
      em1(ir, jr, k) = 0.0D0
      em2(ir, jr, k) = 0.0D0
   60 continue
c
      do 61 k = ngre + 3, mgr
      rhs(ir,     k) = 0.0D0
      e00(ir, jr, k) = 1.0D0
      ep2(ir, jr, k) = 0.0D0
      ep1(ir, jr, k) = 0.0D0
      em1(ir, jr, k) = 0.0D0
      em2(ir, jr, k) = 0.0D0
   61 continue
c
c-----------------------------------------------------------------------
c
      return
      end


 MODULE GDSWZD_EQUID_CYLIND_MOD
!$$$  MODULE DOCUMENTATION BLOCK
!
! $Revision: 74917 $
!
! MODULE:  GDSWZD_EQUID_CYLIND_MOD  GDS WIZARD MODULE FOR EQUIDISTANT
!                                   CYLINDRICAL GRIDS
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: - CONVERT FROM EARTH TO GRID COORDINATES OR VICE VERSA.
!           - COMPUTE VECTOR ROTATION SINES AND COSINES.
!           - COMPUTE MAP JACOBIANS.
!           - COMPUTE GRID BOX AREA.
!
! PROGRAM HISTORY LOG:
!   2015-01-21  GAYNO   INITIAL VERSION FROM A MERGER OF
!                       ROUTINES GDSWIZ00 AND GDSWZD00.
!   2015-09-17  GAYNO   RENAME MODULE TO "GDSWZD_EQUID_CYLIND_MOD"
!
! USAGE:  "USE GDSWZD_EQUID_CYLIND_MOD"  THEN CALL THE PUBLIC DRIVER
!         ROUTINE "GDSWZD_EQUID_CYLIND"
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
!
 IMPLICIT NONE

 PRIVATE

 PUBLIC                  :: GDSWZD_EQUID_CYLIND

 REAL                    :: DLAT ! GRID RESOLUTION IN DEGREES N/S DIRECTION
 REAL                    :: DLON ! GRID RESOLUTION IN DEGREES E/W DIRECTION
 REAL                    :: RERTH

 CONTAINS

 SUBROUTINE GDSWZD_EQUID_CYLIND(IGDTNUM,IGDTMPL,IGDTLEN,IOPT,NPTS,FILL, &
                                XPTS,YPTS,RLON,RLAT,NRET,  &
                                CROT,SROT,XLON,XLAT,YLON,YLAT,AREA)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  GDSWZD_EQUID_CYLIND   GDS WIZARD FOR EQUIDISTANT CYLINDRICAL
!   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-04-10
!
! ABSTRACT: THIS SUBPROGRAM DECODES THE GRIB 2 GRID DEFINITION
!           TEMPLATE (PASSED IN INTEGER FORM AS DECODED BY THE
!           NCEP G2 LIBRARY) AND RETURNS ONE OF THE FOLLOWING:
!             (IOPT=+1) EARTH COORDINATES OF SELECTED GRID COORDINATES
!             (IOPT=-1) GRID COORDINATES OF SELECTED EARTH COORDINATES
!           WORKS FOR EQUIDISTANT CYLINDRICAL PROJECTIONS.
!           IF THE SELECTED COORDINATES ARE MORE THAN ONE GRIDPOINT
!           BEYOND THE THE EDGES OF THE GRID DOMAIN, THEN THE RELEVANT
!           OUTPUT ELEMENTS ARE SET TO FILL VALUES.  THE ACTUAL
!           NUMBER OF VALID POINTS COMPUTED IS RETURNED TOO.
!           OPTIONALLY, THE VECTOR ROTATIONS, MAP JACOBIANS AND
!           GRID BOX AREAS MAY BE RETURNED.  TO COMPUTE THE VECTOR
!           ROTATIONS, THE OPTIONAL ARGUMENTS 'SROT' AND 'CROT'
!           MUST BE PRESENT.  TO COMPUTE THE MAP JACOBIANS, THE
!           OPTIONAL ARGUMENTS 'XLON', 'XLAT', 'YLON', 'YLAT' MUST
!           BE PRESENT. TO COMPUTE THE GRID BOX AREAS, THE OPTIONAL
!           ARGUMENT 'AREA' MUST BE PRESENT.
!
! PROGRAM HISTORY LOG:
!   96-04-10  IREDELL
!   97-10-20  IREDELL  INCLUDE MAP OPTIONS
! 2015-01-21  GAYNO    MERGER OF GDSWIZ00 AND GDSWZD00.  MAKE
!                      CROT,SORT,XLON,XLAT,YLON,YLAT AND AREA
!                      OPTIONAL ARGUMENTS.  MAKE PART OF A MODULE.
!                      MOVE VECTOR ROTATION, MAP JACOBIAN AND GRID
!                      BOX AREA COMPUTATIONS TO SEPARATE SUBROUTINES.
! 2015-07-13  GAYNO    CONVERT TO GRIB 2. REPLACE GRIB 1 KGDS ARRAY
!                      WITH GRIB 2 GRID DEFINITION TEMPLATE ARRAY.
!                      RENAME ROUTINE AS "GDSWZD_EQUID_CYLIND".
!
! USAGE:    CALL GDSWZD_EQUID_CYLIND(IGDTNUM,IGDTMPL,IGDTLEN,IOPT,NPTS,
!    &                  FILL,XPTS,YPTS,RLON,RLAT,NRET,
!    &                  CROT,SROT,XLON,XLAT,YLON,YLAT,AREA)
!
!   INPUT ARGUMENT LIST:
!     IGDTNUM  - INTEGER GRID DEFINITION TEMPLATE NUMBER.
!                CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!                MUST BE "0" FOR EQUIDISTANT CYLINDRICAL
!                PROJECTIONS.
!     IGDTMPL  - INTEGER (IGDTLEN) GRID DEFINITION TEMPLATE ARRAY.
!                CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE FOR SECTION
!                THREE:
!                 (1):  SHAPE OF EARTH, OCTET 15
!                 (2):  SCALE FACTOR OF SPHERICAL EARTH RADIUS,
!                       OCTET 16
!                 (3):  SCALED VALUE OF RADIUS OF SPHERICAL EARTH,
!                       OCTETS 17-20
!                 (4):  SCALE FACTOR OF MAJOR AXIS OF ELLIPTICAL EARTH,
!                       OCTET 21
!                 (5):  SCALED VALUE OF MAJOR AXIS OF ELLIPTICAL EARTH,
!                       OCTETS 22-25
!                 (6):  SCALE FACTOR OF MINOR AXIS OF ELLIPTICAL EARTH,
!                       OCTET 26
!                 (7):  SCALED VALUE OF MINOR AXIS OF ELLIPTICAL EARTH,
!                       OCTETS 27-30
!                 (8):  NUMBER OF POINTS ALONG A PARALLEL, OCTS 31-34
!                 (9):  NUMBER OF POINTS ALONG A MERIDIAN, OCTS 35-38
!                 (10): BASIC ANGLE OF INITIAL PRODUCTION DOMAIN,
!                       OCTETS 39-42.
!                 (11): SUBDIVISIONS OF BASIC ANGLE, OCTETS 43-46
!                 (12): LATITUDE OF FIRST GRID POINT, OCTETS 47-50
!                 (13): LONGITUDE OF FIRST GRID POINT, OCTETS 51-54
!                 (14): RESOLUTION AND COMPONENT FLAGS, OCTET 55
!                 (15): LATITUDE OF LAST GRID POINT, OCTETS 56-59
!                 (16): LONGITUDE OF LAST GRID POINT, OCTETS 60-63
!                 (17): I-DIRECTION INCREMENT, OCTETS 64-67
!                 (18): J-DIRECTION INCREMENT, OCTETS 68-71
!                 (19): SCANNING MODE, OCTET 72
!     IGDTLEN  - INTEGER NUMBER OF ELEMENTS (19) OF THE GRID DEFINITION
!                TEMPLATE ARRAY.  CORRESPONDS TO THE GFLD%IGDTLEN
!                COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IOPT     - INTEGER OPTION FLAG
!                (+1 TO COMPUTE EARTH COORDS OF SELECTED GRID COORDS)
!                (-1 TO COMPUTE GRID COORDS OF SELECTED EARTH COORDS)
!     NPTS     - INTEGER MAXIMUM NUMBER OF COORDINATES
!     FILL     - REAL FILL VALUE TO SET INVALID OUTPUT DATA
!                (MUST BE IMPOSSIBLE VALUE; SUGGESTED VALUE: -9999.)
!     XPTS     - REAL (NPTS) GRID X POINT COORDINATES IF IOPT>0
!     YPTS     - REAL (NPTS) GRID Y POINT COORDINATES IF IOPT>0
!     RLON     - REAL (NPTS) EARTH LONGITUDES IN DEGREES E IF IOPT<0
!                (ACCEPTABLE RANGE: -360. TO 360.)
!     RLAT     - REAL (NPTS) EARTH LATITUDES IN DEGREES N IF IOPT<0
!                (ACCEPTABLE RANGE: -90. TO 90.)
!
!   OUTPUT ARGUMENT LIST:
!     XPTS     - REAL (NPTS) GRID X POINT COORDINATES IF IOPT<0
!     YPTS     - REAL (NPTS) GRID Y POINT COORDINATES IF IOPT<0
!     RLON     - REAL (NPTS) EARTH LONGITUDES IN DEGREES E IF IOPT>0
!     RLAT     - REAL (NPTS) EARTH LATITUDES IN DEGREES N IF IOPT>0
!     NRET     - INTEGER NUMBER OF VALID POINTS COMPUTED
!     CROT     - REAL, OPTIONAL (NPTS) CLOCKWISE VECTOR ROTATION COSINES
!     SROT     - REAL, OPTIONAL (NPTS) CLOCKWISE VECTOR ROTATION SINES
!                (UGRID=CROT*UEARTH-SROT*VEARTH;
!                 VGRID=SROT*UEARTH+CROT*VEARTH)
!     XLON     - REAL, OPTIONAL (NPTS) DX/DLON IN 1/DEGREES
!     XLAT     - REAL, OPTIONAL (NPTS) DX/DLAT IN 1/DEGREES
!     YLON     - REAL, OPTIONAL (NPTS) DY/DLON IN 1/DEGREES
!     YLAT     - REAL, OPTIONAL (NPTS) DY/DLAT IN 1/DEGREES
!     AREA     - REAL, OPTIONAL (NPTS) AREA WEIGHTS IN M**2
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
 IMPLICIT NONE
!
 INTEGER,             INTENT(IN   ) :: IGDTNUM, IGDTLEN
 INTEGER,             INTENT(IN   ) :: IGDTMPL(IGDTLEN)
 INTEGER,             INTENT(IN   ) :: IOPT, NPTS
 INTEGER,             INTENT(  OUT) :: NRET
!
 REAL,                INTENT(IN   ) :: FILL
 REAL,                INTENT(INOUT) :: RLON(NPTS),RLAT(NPTS)
 REAL,                INTENT(INOUT) :: XPTS(NPTS),YPTS(NPTS)
 REAL, OPTIONAL,      INTENT(  OUT) :: CROT(NPTS),SROT(NPTS)
 REAL, OPTIONAL,      INTENT(  OUT) :: XLON(NPTS),XLAT(NPTS)
 REAL, OPTIONAL,      INTENT(  OUT) :: YLON(NPTS),YLAT(NPTS),AREA(NPTS)
!
 INTEGER                            :: IM, JM, ISCAN, N, ISCALE
!
 LOGICAL                            :: LROT, LMAP, LAREA
!
 REAL                               :: ECCEN_SQUARED
 REAL                               :: HI, RLAT1, RLON1, RLAT2, RLON2
 REAL                               :: XMAX, XMIN, YMAX, YMIN
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 IF(PRESENT(CROT)) CROT=FILL
 IF(PRESENT(SROT)) SROT=FILL
 IF(PRESENT(XLON)) XLON=FILL
 IF(PRESENT(XLAT)) XLAT=FILL
 IF(PRESENT(YLON)) YLON=FILL
 IF(PRESENT(YLAT)) YLAT=FILL
 IF(PRESENT(AREA)) AREA=FILL
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! IS THIS AN EQUIDISTANT CYCLINDRICAL GRID?
 IF(IGDTNUM/=0)THEN
   CALL EQUID_CYLIND_ERROR(IOPT,FILL,RLAT,RLON,XPTS,YPTS,NPTS)
   RETURN
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 CALL EARTH_RADIUS(IGDTMPL,IGDTLEN,RERTH,ECCEN_SQUARED)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  ENSURE EARTH RADIUS IS DEFINED.
 IF(RERTH<0.) THEN
   CALL EQUID_CYLIND_ERROR(IOPT,FILL,RLAT,RLON,XPTS,YPTS,NPTS)
   RETURN
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 IM=IGDTMPL(8)
 JM=IGDTMPL(9)
 ISCALE=IGDTMPL(10)*IGDTMPL(11)
 IF(ISCALE==0) ISCALE=10**6
 RLAT1=FLOAT(IGDTMPL(12))/FLOAT(ISCALE)
 RLON1=FLOAT(IGDTMPL(13))/FLOAT(ISCALE)
 RLAT2=FLOAT(IGDTMPL(15))/FLOAT(ISCALE)
 RLON2=FLOAT(IGDTMPL(16))/FLOAT(ISCALE)
 ISCAN=MOD(IGDTMPL(19)/128,2)
 HI=(-1.)**ISCAN
 DLON=HI*(MOD(HI*(RLON2-RLON1)-1+3600,360.)+1)/(IM-1)
 DLAT=(RLAT2-RLAT1)/(JM-1)
 XMIN=0
 XMAX=IM+1
 IF(IM.EQ.NINT(360/ABS(DLON))) XMAX=IM+2
 YMIN=0
 YMAX=JM+1
 NRET=0
 IF(PRESENT(CROT).AND.PRESENT(SROT))THEN
   LROT=.TRUE.
 ELSE
   LROT=.FALSE.
 ENDIF
 IF(PRESENT(XLON).AND.PRESENT(XLAT).AND.PRESENT(YLON).AND.PRESENT(YLAT))THEN
   LMAP=.TRUE.
 ELSE
   LMAP=.FALSE.
 ENDIF
 IF(PRESENT(AREA))THEN
   LAREA=.TRUE.
 ELSE
   LAREA=.FALSE.
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  TRANSLATE GRID COORDINATES TO EARTH COORDINATES
 IF(IOPT.EQ.0.OR.IOPT.EQ.1) THEN
!$OMP PARALLEL DO PRIVATE(N) REDUCTION(+:NRET) SCHEDULE(STATIC)
   DO N=1,NPTS
     IF(XPTS(N).GE.XMIN.AND.XPTS(N).LE.XMAX.AND. &
        YPTS(N).GE.YMIN.AND.YPTS(N).LE.YMAX) THEN
       RLON(N)=MOD(RLON1+DLON*(XPTS(N)-1)+3600,360.)
       RLAT(N)=MIN(MAX(RLAT1+DLAT*(YPTS(N)-1),-90.),90.)
       NRET=NRET+1
       IF(LROT)  CALL EQUID_CYLIND_VECT_ROT(CROT(N),SROT(N))
       IF(LMAP)  CALL EQUID_CYLIND_MAP_JACOB(XLON(N),XLAT(N),YLON(N),YLAT(N))
       IF(LAREA) CALL EQUID_CYLIND_GRID_AREA(RLAT(N),AREA(N))
     ELSE
       RLON(N)=FILL
       RLAT(N)=FILL
     ENDIF
   ENDDO
!$OMP END PARALLEL DO
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  TRANSLATE EARTH COORDINATES TO GRID COORDINATES
 ELSEIF(IOPT.EQ.-1) THEN
!$OMP PARALLEL DO PRIVATE(N) REDUCTION(+:NRET) SCHEDULE(STATIC)
   DO N=1,NPTS
     IF(ABS(RLON(N)).LE.360.AND.ABS(RLAT(N)).LE.90) THEN
       XPTS(N)=1+HI*MOD(HI*(RLON(N)-RLON1)+3600,360.)/DLON
       YPTS(N)=1+(RLAT(N)-RLAT1)/DLAT
       IF(XPTS(N).GE.XMIN.AND.XPTS(N).LE.XMAX.AND.  &
          YPTS(N).GE.YMIN.AND.YPTS(N).LE.YMAX) THEN
         NRET=NRET+1
         IF(LROT)  CALL EQUID_CYLIND_VECT_ROT(CROT(N),SROT(N))
         IF(LMAP)  CALL EQUID_CYLIND_MAP_JACOB(XLON(N),XLAT(N),YLON(N),YLAT(N))
         IF(LAREA) CALL EQUID_CYLIND_GRID_AREA(RLAT(N),AREA(N))
       ELSE
         XPTS(N)=FILL
         YPTS(N)=FILL
       ENDIF
     ELSE
       XPTS(N)=FILL
       YPTS(N)=FILL
     ENDIF
   ENDDO
!$OMP END PARALLEL DO
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE GDSWZD_EQUID_CYLIND
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 SUBROUTINE EQUID_CYLIND_ERROR(IOPT,FILL,RLAT,RLON,XPTS,YPTS,NPTS)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  EQUID_CYLIND_ERROR   ERROR HANDLER
!   PRGMMR: GAYNO       ORG: W/NMC23       DATE: 2015-07-13
!
! ABSTRACT: UPON AN ERROR, THIS SUBPROGRAM ASSIGNS
!           A "FILL" VALUE TO THE OUTPUT FIELDS.
!
! PROGRAM HISTORY LOG:
! 2015-07-13  GAYNO     INITIAL VERSION
!
! USAGE:    CALL EQUID_CYLIND_ERROR(IOPT,FILL,RLAT,RLON,XPTS,YPTS,NPTS)
!
!   INPUT ARGUMENT LIST:
!     IOPT     - INTEGER OPTION FLAG
!                (+1 TO COMPUTE EARTH COORDS OF SELECTED GRID COORDS)
!                (-1 TO COMPUTE GRID COORDS OF SELECTED EARTH COORDS)
!     NPTS     - INTEGER MAXIMUM NUMBER OF COORDINATES
!     FILL     - REAL FILL VALUE TO SET INVALID OUTPUT DATA
!                (MUST BE IMPOSSIBLE VALUE; SUGGESTED VALUE: -9999.)
!   OUTPUT ARGUMENT LIST:
!     RLON     - REAL (NPTS) EARTH LONGITUDES IN DEGREES E IF IOPT<0
!     RLAT     - REAL (NPTS) EARTH LATITUDES IN DEGREES N IF IOPT<0
!     XPTS     - REAL (NPTS) GRID X POINT COORDINATES IF IOPT>0
!     YPTS     - REAL (NPTS) GRID Y POINT COORDINATES IF IOPT>0
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
 IMPLICIT NONE
!
 INTEGER, INTENT(IN   ) :: IOPT, NPTS
!
 REAL,    INTENT(IN   ) :: FILL
 REAL,    INTENT(  OUT) :: RLAT(NPTS),RLON(NPTS)
 REAL,    INTENT(  OUT) :: XPTS(NPTS),YPTS(NPTS)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 IF(IOPT>=0) THEN
   RLON=FILL
   RLAT=FILL
 ENDIF
 IF(IOPT<=0) THEN
   XPTS=FILL
   YPTS=FILL
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE EQUID_CYLIND_ERROR
!
 SUBROUTINE EQUID_CYLIND_VECT_ROT(CROT,SROT)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  EQUID_CYLIND_VECT_ROT   VECTOR ROTATION FIELDS FOR
!                                      EQUIDISTANT CYLINDRICAL GRIDS
!
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: THIS SUBPROGRAM COMPUTES THE VECTOR ROTATION SINES AND
!           COSINES FOR AN EQUIDISTANT CYLINDRICAL GRID.
!
! PROGRAM HISTORY LOG:
! 2015-01-21  GAYNO    INITIAL VERSION
! 2015-09-17  GAYNO    RENAME AS "EQUID_CYLIND_VECT_ROT"
!
! USAGE:    CALL EQUID_CYLIND_VECT_ROT(CROT,SROT)
!
!   INPUT ARGUMENT LIST:
!     NONE
!
!   OUTPUT ARGUMENT LIST:
!     CROT     - CLOCKWISE VECTOR ROTATION COSINES (REAL)
!     SROT     - CLOCKWISE VECTOR ROTATION SINES (REAL)
!                (UGRID=CROT*UEARTH-SROT*VEARTH;
!                 VGRID=SROT*UEARTH+CROT*VEARTH)
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
 IMPLICIT NONE

 REAL,                INTENT(  OUT) :: CROT, SROT

 CROT=1.0
 SROT=0.0

 END SUBROUTINE EQUID_CYLIND_VECT_ROT
!
 SUBROUTINE EQUID_CYLIND_MAP_JACOB(XLON,XLAT,YLON,YLAT)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  EQUID_CYLIND_MAP_JACOB  MAP JACOBIANS FOR
!                                      EQUIDISTANT CYLINDRICAL GRIDS
!
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: THIS SUBPROGRAM COMPUTES THE MAP JACOBIANS FOR
!           AN EQUIDISTANT CYLINDRICAL GRID.
!
! PROGRAM HISTORY LOG:
! 2015-01-21  GAYNO    INITIAL VERSION
! 2015-09-17  GAYNO    RENAME AS "EQUID_CYLIND_MAP_JACOB"
!
! USAGE:  CALL EQUID_CYLIND_MAP_JACOB(XLON,XLAT,YLON,YLAT)
!
!   INPUT ARGUMENT LIST:
!     NONE
!
!   OUTPUT ARGUMENT LIST:
!     XLON     - DX/DLON IN 1/DEGREES (REAL)
!     XLAT     - DX/DLAT IN 1/DEGREES (REAL)
!     YLON     - DY/DLON IN 1/DEGREES (REAL)
!     YLAT     - DY/DLAT IN 1/DEGREES (REAL)
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$

 REAL,                INTENT(  OUT) :: XLON,XLAT,YLON,YLAT

 XLON=1.0/DLON
 XLAT=0.
 YLON=0.
 YLAT=1.0/DLAT

 END SUBROUTINE EQUID_CYLIND_MAP_JACOB
!
 SUBROUTINE EQUID_CYLIND_GRID_AREA(RLAT,AREA)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  EQUID_CYLIND_GRID_AREA  GRID BOX AREA FOR
!                                      EQUIDISTANT CYLINDRICAL GRIDS
!
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: THIS SUBPROGRAM COMPUTES THE GRID BOX AREA FOR
!           AN EQUIDISTANT CYLINDRICAL GRID.
!
! PROGRAM HISTORY LOG:
! 2015-01-21  GAYNO    INITIAL VERSION
! 2015-09-17  GAYNO    RENAME AS "EQUID_CYLIND_GRID_AREA"
!
! USAGE:  CALL EQUID_CYLIND_GRID_AREA(RLAT,AREA)
!
!   INPUT ARGUMENT LIST:
!     RLAT     - LATITUDE OF GRID POINT IN DEGREES (REAL)
!
!   OUTPUT ARGUMENT LIST:
!     AREA     - AREA WEIGHTS IN M**2 (REAL)
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
 IMPLICIT NONE

 REAL,                INTENT(IN   ) :: RLAT
 REAL,                INTENT(  OUT) :: AREA

 REAL,                PARAMETER     :: PI=3.14159265358979
 REAL,                PARAMETER     :: DPR=180./PI

 REAL                               :: DSLAT, RLATU, RLATD

 RLATU=MIN(MAX(RLAT+DLAT/2,-90.),90.)
 RLATD=MIN(MAX(RLAT-DLAT/2,-90.),90.)
 DSLAT=SIN(RLATU/DPR)-SIN(RLATD/DPR)
 AREA=RERTH**2*ABS(DSLAT*DLON)/DPR

 END SUBROUTINE EQUID_CYLIND_GRID_AREA

 END MODULE GDSWZD_EQUID_CYLIND_MOD