c /***************************************************
c   gasdgen.f  for dbulhalo
c   13 Sep. 2012  written by D.Kawata
c ****************************************************/
c70*******************************************************************

c /*****   generating exponential disk *****/
      subroutine gasdgen(np,mtdisk,mdisk,hd,rdlim,zdlim,ngr,ngz,id
     &  ,flagb,dfeh,feh0,dalfe,alfe0,flaggd)
      include 'define.f'
      integer np,nd,ngr,ngz,id,flagb,flaggd
      character filen*60
      double precision mtdisk,mdisk,hd,rdlim,zdlim
      double precision dfeh,feh0,dalfe,alfe0
      integer i,j,pn,pno,pni
      integer nrp,ndrm
      double precision pfr,ph,dr
c *** Exp disk profile ***
      integer irlim
      double precision mrexpd(MNR),rexpd(MNR),rlim
      double precision ri,ro,lri,lro,dlr,rp,mdp,rr,mrp
c *** for particle data ***
      double precision xbp,ybp,zbp,vxbp,vybp,vzbp,mbp,rhobp,pbp
     & ,tmbp,myubp,nhp
c *** to get total mass for z profile ***
      integer ir,iz
      double precision fsum,rhoz,prhoz,pzp,zp,dz,rmz
      integer pnrizi,pnrizo,pnrozi,pnrozo
      double precision wrizi,wrizo,wrozi,wrozo
      double precision wr1,wr2,mzzo,mzzi,dmz
c *** for velocity ***
      double precision vsigz,vsigr,vsigph,vphm
      double precision vrp,vphp
c *** for checking density profile ***
      integer ndrpr,ndzpr,irpr,izpr,nppr(0:MN2D,0:MN2D)
      double precision rlimpr(0:1),zlimpr(0:1)
      double precision logripr,logzipr,dlogrpr,dlogzpr
      double precision rhopr(0:MN2D,0:MN2D),zi,zo,dvpr
c *** external function ***
      double precision mrexpdf,mrexp2dr
      external mrexpdf,mrexp2dr
c *** external function
      integer idum
      real ran1,gasdev
      external ran1,gasdev

      idum = -111-id
c use mdisk (M(<rdlim)) for particle mass
      mdp=mdisk/dble(np)
      if(myrank.eq.0) then
        write(6,*) id,' disk particle mass=',mdp
        write(6,*) 'flaggd=',flaggd
      endif

c *** find rlim
      rlim=0.0d0
      irlim=0
      if(flaggd.le.2) then
        do i=0,ngr
          pn=id_rzg(i,0)
          rhoz=rho_rzg(pn)
          if(rhoz.lt.RHO_LIM*1.001d0) then
            irlim=i
            rlim=x_rzg(pn)
            goto 68
          endif
        enddo
      endif
      irlim=ngr
      pn=id_rzg(ngr,0)
      rlim=x_rzg(pn)
c *** for radial profile use analytic formula
  68  ri = 1.0e-6*rdlim
      ro = rdlim
      lri = dlog10(ri)
      lro = dlog10(ro)
      dlr = (lro-lri)/dble(ndr-2)
c *** set mr and r ***
      rexpd(1) = 0.0d0
      mrexpd(1) = 0.0d0
      if(flaggd.le.1) then
        do i=2,ndr
          rexpd(i) = 10.0d0**(lri+dlr*dble(i-2))
          rr = rexpd(i)
          if(rr.lt.rlim) then
c        mrexpd(i) = 1.0d0-(1.0d0+rr/hd)*dexp(-rr/hd)
c mass fraction
            mrexpd(i)=mrexpdf(rr,hd,mtdisk)/mdisk
            if(mrexpd(i).gt.1.0d0) then
              if(myrank.eq.0) then
                write(6,*) ' warning mrexpd>1, i,r,mrexpd=',i,rr
     &            ,mrexpd(i)
              endif
            endif
            irlim=i
          else
            mrexpd(i)=1.0d0
          endif
        enddo
      else if(flaggd.eq.2) then
        do i=2,ndr
          rexpd(i) = 10.0d0**(lri+dlr*dble(i-2))
          rr = rexpd(i)
          if(rr.lt.hd) then
c        mrexpd(i) = 1.0d0-(1.0d0+rr/hd)*dexp(-rr/hd)
            mrexpd(i)=(rr/hd)**2
            irlim=i
          else
            mrexpd(i)=1.0d0
          endif
        enddo
      else
        do i=2,ndr
          rexpd(i) = 10.0d0**(lri+dlr*dble(i-2))
          rr = rexpd(i)
          if(rr.lt.rlim) then
c        mrexpd(i) = 1.0d0-(1.0d0+rr/hd)*dexp(-rr/hd)
c mass fraction
            mrexpd(i)=mrexp2dr(rr)/mdisk
            if(mrexpd(i).gt.1.0d0) then
              if(myrank.eq.0) then
                write(6,*) ' warning mrexpd>1, i,r,mrexpd=',i,rr
     &            ,mrexpd(i)
              endif
            endif
            irlim=i
          else
            mrexpd(i)=1.0d0
          endif
        enddo
      endif

      if(myrank.eq.0) then
        write(6,*) ' rlim,irlim,mr=',rlim,irlim,mrexpd(irlim)
      endif
c *** set M(<z) use _rzg
      do i=0,ngr
        j=0
        pn=id_rzg(i,j)
        mz_rzg(pn)=0.0d0
        rhoz=rho_rzg(pn)
        if(rhoz.lt.RHO_LIM*1.001d0) then
          rhoz=0.0d0
        endif
        zp=z_rzg(pn)
        fsum=0.0d0
        do j=1,ngz
          prhoz=rhoz
          pn=id_rzg(i,j)
          rhoz=rho_rzg(pn)
          if(rhoz.lt.RHO_LIM*1.001d0) then
            rhoz=0.0d0
          endif
          pzp=zp
          zp=z_rzg(pn)
          dz=zp-pzp
          fsum=fsum+dz*0.5d0*(rhoz+prhoz)
          mz_rzg(pn)=fsum
        enddo
c *** normalise ***
        if(fsum.gt.0.0d0) then
          do j=1,ngz
            pn=id_rzg(i,j)
            mz_rzg(pn)=mz_rzg(pn)/fsum
          enddo
        endif
      enddo

      open(60,file='mzgas.dat',status='unknown')
      do i=1,ngr
        do j=1,ngr
          pn=id_rzg(i,j)
          write(60,'(4(1pE13.5))') x_rzg(pn),z_rzg(pn),mz_rzg(pn)
     &     ,rho_rzg(pn)
        enddo
      enddo
      close(60)

c*** start generating particles ***
      if(myrank.eq.0) then

      write(filen,'(a12,i1,a4)') 'output/diskc',id,'.dat'
      if(flagb.eq.0) then
        open(60,file=filen,status='unknown',form='unformatted')
        write(60) np,1
        write(60) dfeh,feh0,dalfe,alfe0
      else
        open(60,file=filen,status='unknown')
        write(60,'(a8,2I8)') '#n,flag=',np,1
        write(60,'(a1,4(1pE13.5))') '#'
     &   ,dfeh,feh0,dalfe,alfe0
      endif

c check profile
      ndrpr=50
      ndzpr=50
      rlimpr(1)=rdlim
      zlimpr(1)=zdlim
      rlimpr(0)=rdlim*1.0e-3
      zlimpr(0)=zdlim*1.0e-3
      dlogrpr=(dlog10(rlimpr(1))-dlog10(rlimpr(0)))/dble(ndrpr)
      dlogzpr=(dlog10(zlimpr(1))-dlog10(zlimpr(0)))/dble(ndzpr)
      logripr=dlog10(rlimpr(0))
      logzipr=dlog10(zlimpr(0))
      write(6,*) ' for gas density profile=',rlimpr(0),rlimpr(1)
     &  ,zlimpr(0),zlimpr(1),dlogrpr,dlogzpr,logripr,logzipr
      do j=0,ndzpr
        do i=0,ndrpr
          rhopr(i,j)=0.0d0
          nppr(i,j)=0
        enddo
      enddo

      do i=0,np-1
 67     pfr = dble(ran1(idum))
        if(pfr.gt.mrexpd(irlim)) then
          goto  67
        endif
c /*** search radius ***/
        do j=1,ndr
          if(mrexpd(j).gt.pfr) then
            goto 72
          endif
        enddo
c        write(6,*) ' Warning: in finding radius for disk'
c        write(6,*) '  pfr =',pfr
        goto 67
 72     if(j.eq.1) then
          write(6,*) ' Warning: in finding radius for disk: j,mr,prf='
     &      ,j,mrexpd(j),pfr
          pn=id_rzg(irlim,0)
        write(6,*) ' rlim,irlim,mr,rho=',rlim,irlim,mrexpd(irlim)
     &    ,rho_rzg(pn),RHO_LIM*1.001d0
          j = 2
        endif
        if(mrexpd(j)-mrexpd(j-1).gt.0.0d0) then
          rp=10.0d0**(dlog10(rexpd(j-1))
     &    +(dlog10(rexpd(j))-dlog10(rexpd(j-1)))
     &    *(dlog10(pfr)-dlog10(mrexpd(j-1)))
     &    /(dlog10(mrexpd(j))-dlog10(mrexpd(j-1))))
        else
          if(myrank.eq.0) then
            write(6,*) ' cannot find r for pfr=',pfr
          endif
          goto 67
        endif
c        if(myrank.eq.0) then
c          write(6,*) j,rexpd(j-1),rexpd(j),pfr,mrexpd(j-1),mrexpd(j)
c        endif
        rr=rp
        ph =  2.0d0*M_PI*dble(ran1(idum))
        mbp=mdp
        xbp=rp*dcos(ph)
        ybp=rp*dsin(ph)
c *** z-axis ****
 66     pfr = dble(ran1(idum))
c *** set r range ***
        if(rp.gt.0.0d0) then
          ir=int((dlog10(rp)-lri_rzg)/dlr_rzg)+1
        else
          ir=0
        endif
        if(ir.lt.0) then
          ir=0
        else if(ir.gt.ngr-1) then
          ir=ngr-1
        endif
c *** search z for ir ***
        pni=id_rzg(ir,1)
        pno=id_rzg(ir+1,1)
c *** calculate weight for r direction ***
        dr=x_rzg(pno)-x_rzg(pni)
        wr1=(x_rzg(pno)-rr)/dr
        wr2=(rr-x_rzg(pni))/dr
        mzzo=0.0d0
        do j=0,ngz
          pni=id_rzg(ir,j)
          pno=id_rzg(ir+1,j)
          mzzi=mzzo
          mzzo=wr1*mz_rzg(pni)+wr2*mz_rzg(pno)
          if(mzzo.gt.pfr) then
            goto 73
          endif
        enddo
        if(myrank.eq.0) then
          write(6,*) ' Warning: in finding z for disk'
          write(6,*) '  pfr,r,mzmax=',pfr,rp,mzzo,wr1,wr2
        endif
        goto 66
 73     iz=j-1
        dmz=mzzo-mzzi
        pni=id_rzg(ir,iz)
        pno=id_rzg(ir,iz+1)
        dz=z_rzg(pno)-z_rzg(pni)
c *** z coordinate ***
        zbp=z_rzg(pni)+dz*(pfr-mzzi)/dmz
        zp=zbp
        if(dble(ran1(idum)).lt.0.5d0) then
          zbp=-zbp
        endif
c *** density ***
c *** find the point in z_rzg ***
        if(zp.gt.0.0d0) then
          iz=int((dlog10(zp)-lzi_rzg)/dlz_rzg)+1
        else
          iz=0
        endif
        if(iz.lt.0) then
          iz=0
        else if(iz.gt.ngz-1) then
          iz=ngz-1
        endif
        pnrizi=id_rzg(ir,iz)
        pnrizo=id_rzg(ir,iz+1)
        pnrozi=id_rzg(ir+1,iz)
        pnrozo=id_rzg(ir+1,iz+1)
        dr=x_rzg(pnrozi)-x_rzg(pnrizi)
        dz=z_rzg(pnrizo)-z_rzg(pnrizi)
c weight
        wrizi=(x_rzg(pnrozi)-rr)*(z_rzg(pnrizo)-zp)/(dr*dz)
        wrizo=(x_rzg(pnrozo)-rr)*(zp-z_rzg(pnrizi))/(dr*dz)
        wroz i=(rr-x_rzg(pnrizi))*(z_rzg(pnrozo)-zp)/(dr*dz)
        wrozo=(rr-x_rzg(pnrizo))*(zp-z_rzg(pnrozi))/(dr*dz)
c *** density ***
        rhobp=wrizi*rho_rzg(pnrizi)+wrizo*rho_rzg(pnrizo)
     &   +wrozi*rho_rzg(pnrozi)+wrozo*rho_rzg(pnrozo)
c *** pressure ***
        pbp=wrizi*p_rzg(pnrizi)+wrizo*p_rzg(pnrizo)
     &   +wrozi*p_rzg(pnrozi)+wrozo*p_rzg(pnrozo)
c *** myu ***
        myubp=wrizi*myu_rzg(pnrizi)+wrizo*myu_rzg(pnrizo)
     &   +wrozi*myu_rzg(pnrozi)+wrozo*myu_rzg(pnrozo)
c *** T ***
        tmbp=wrizi*tm_rzg(pnrizi)+wrizo*tm_rzg(pnrizo)
     &   +wrozi*tm_rzg(pnrozi)+wrozo*tm_rzg(pnrozo)
c *** velocity ***
c *** vphm
        vphm=wrizi*vph_rzg(pnrizi)+wrizo*vph_rzg(pnrizo)
     &   +wrozi*vph_rzg(pnrozi)+wrozo*vph_rzg(pnrozo)
        if(vphm.lt.0.0d0) then
          vphm=0.0d0
        endif
c *** vsigph
        vsigph=wrizi*vsigph_rzg(pnrizi)+wrizo*vsigph_rzg(pnrizo)
     &   +wrozi*vsigph_rzg(pnrozi)+wrozo*vsigph_rzg(pnrozo)
        if(vsigph.lt.0.0d0) then
          vsigph=0.0d0
        endif
c *** vsigr
        vsigr=wrizi*vsigr_rzg(pnrizi)+wrizo*vsigr_rzg(pnrizo)
     &   +wrozi*vsigr_rzg(pnrozi)+wrozo*vsigr_rzg(pnrozo)
        if(vsigr.lt.0.0d0) then
          vsigr=0.0d0
        endif
c *** vsigz
        vsigz=wrizi*vsigz_rzg(pnrizi)+wrizo*vsigz_rzg(pnrizo)
     &   +wrozi*vsigz_rzg(pnrozi)+wrozo*vsigz_rzg(pnrozo)
        if(vsigz.lt.0.0d0) then
          vsigz=0.0d0
        endif
c *** get vph,vr,vz
        vphp=vphm+vsigph*dble(gasdev(idum))
        vrp=vsigr*dble(gasdev(idum))
        vzbp=vsigz*dble(gasdev(idum))
c *** convert vr,vph -> vx,vy ***
        if(rp.gt.0.0d0) then
          vxbp=vrp*xbp/rp-vphp*ybp/rp
          vybp=vrp*ybp/rp+vphp*xbp/rp
        else
          vxbp=0.0d0
          vybp=0.0d0
        endif
c *** output
        if(flagb.eq.0) then
          write(60) xbp,ybp,zbp,vxbp,vybp,vzbp,mbp,rhobp,pbp,myubp
        else
          write(60,160) xbp,ybp,zbp,vxbp,vybp,vzbp,mbp,rhobp,pbp
     &     ,tmbp,myubp,pbp/((GAM-1.0d0)*rhobp),vsigz,vrp
     &     ,((GAM-1.0d0)*TUK/TPRHO)*pbp/((GAM-1.0d0)*rhobp)
 160      format(15(1pE13.5))
        endif
c *** profile
        if(rp.le.rlimpr(0)) then
          irpr=0
        else if(rp.gt.rlimpr(1)) then
          irpr=ndrpr+1
        else
          irpr=int((dlog10(rp)-logripr)/dlogrpr)+1
        endif
        if(dabs(zbp).le.zlimpr(0)) then
          izpr=0
        else if(dabs(zbp).gt.rlimpr(1)) then
          izpr=ndzpr+1
        else
          izpr=int((dlog10(dabs(zbp))-logzipr)/dlogrpr)+1
        endif
        rhopr(irpr,izpr)=rhopr(irpr,izpr)+mbp
        nppr(irpr,izpr)=nppr(irpr,izpr)+1
      enddo

      close(60)

c *** output profile
      open(60,file='gasprof.dat',status='unknown')
      zo=0.0d0
      do j=0,ndzpr
        zp=10.0d0**(logzipr+(dble(j)+0.5d0)*dlogzpr)
        zi=zo
        zo=10.0d0**(logzipr+(dble(j)+1.0d0)*dlogzpr)
        ro=0.0d0
        do i=0,ndrpr
          rp=10.0d0**(logripr+(dble(i)+0.5)*dlogrpr)
          ri=ro
          ro=10.0d0**(logripr+(dble(i)+1.0d0)*dlogrpr)
          dvpr=(zo-zi)*M_PI*(ro**2-ri**2)
          rhopr(i,j)=0.5d0*rhopr(i,j)/dvpr
          write(60,'(3(1pE13.5),I10)') rp,zp,rhopr(i,j),nppr(i,j)
        enddo
      enddo

c *** only for myrank 0
      endif
      call MPI_BARRIER(MPI_COMM_WORLD,ierr)

      return
      end


!====================================================================
!-----------------------------------------------------------------------
!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-----------------------------------------------------------------------
!BOI
! !MODULE: m_StdAtm -- Return parameters for the 1976 standard atmosphere.
!
! !DESCRIPTION:
!     This module contains routines that return the parameters for the
!     1976 standard atmosphere at given geopotential height(s) or pressure
!     level(s).  The list of returned parameters and their default units
!     is as follows:
! \begin{verbatim}
!                                units
!     Z  - geoopotential height     m
!     P  - pressure                 HPa (or mb)
!     T  - absolute temperature     deg K
!     R  - density of dry air (rho) Kg/m^3
! \end{verbatim}
!     The output parameter from these routines are valid only for heights
!     upto the mesopause at 84.852 km (282,152 ft) or pressures as low as
!     0.00373 HPa.  If the input values are outside this range, then the
!     output parameters will be returned but should be considered
!     inaccurate.  Altitude instead of geopotential height can be used by
!     setting the optional parameter \verb|alt| to \verb|.true.|
!
! !INTERFACE:
!
      module      m_StdAtm
      implicit    NONE
      private	! except

      public ::
     .   StdP2Z,    ! Returns the standard geopotential height
     .   StdP2T,    ! ... temperature
     .   StdP2R,    ! ... or pressure for a single pressure level.
     .   StdAtmP,   ! Returns height, temperature and/or density for
     .              !   given pressure level(s)
     .   StdZ2P,    ! Returns the standard height
     .   StdZ2T,    ! ... temperature
     .   StdZ2R,    ! ... or pressure for a single height value.
     .   StdAtmZ    ! Returns pressure, temperature and/or density for
                    !   given geopotential height(s)
      public ::
     .   ZMax       ! Max height for the standard atmosphere (in m)
!
! !REVISION HISTORY:
!     25Jun2001  C. Redder  Revised for use at the DAO
!     28Sep2001  C. Redder  Minor revisions to module prologue and added the
!                           functions StdP2T, StdZ2T, StdZ2R, and StdP2R
!     07Oct2003  C. Redder  Added the public entity, ZMax
!
!EOI
!-----------------------------------------------------------------

!     Parameters defining the layers of the standard atmosphere where
!     HTab, TTab, and PTab are the geopotential height (in m),
!     temperature (in deg K) at the base of the layer and normalized
!     pressure at the bottom of each layer, and LTab, is the lapse rate
!     (= -dT/dZ in deg K/km) for the each layer.
!     -----------------------------------------------------------------
      integer, parameter :: NLayers = 8
      real,    parameter, dimension ( NLayers ) ::
     .  ZTab = (/  0.0,         11.0,         20.0,         32.0,
     .            47.0,         51.0,         71.0,         84.852   /),
     .  TTab = (/288.15,       216.65,       216.65,       228.65,
     .           270.65,       270.65,       214.65,       186.946   /),
     .  LTab = (/ -6.5,          0.0,          1.0,          2.8,
     .             0.0,         -2.8,         -2.0,          0.0     /),
     .  PTab = (/1.0,          2.233611E-1,  5.403295E-2,  8.5666784E-3,
     .           1.0945601E-3, 6.6063531E-4, 3.9046834E-5, 3.68501E-6/)

!
      real,    parameter ::
     .  ZMin = -2000.0,
     .  ZMax =  84852.0

!     Geophysical parameters
!     ----------------------
      real, parameter ::
     .  tpz_km =    11.0,  ! Height at the tropopause in km
     .  slt_K  =  TTab (1),! Temperature at sea level in deg K
     .  tpzDef = 11000.0,  ! Default height at the tropopause
     .  slpDef =  1013.25, ! Default sea level pressure (HPa or mb)
     .  sltDef =  TTab (1),! ... temperature        (deg K)
     .  slrDef =     1.225,! ... density of dry air (Kg / m^3)
     .  REarth =  6369.0,  ! Radius of the Earth    (km)
     .  GMR    = 34.163195 ! = 1000 * g0 / R where R is the gas constant
                           !   for dry air (=287.05307 J/(kg-deg K)) and
      contains             !   g0 is the global average of gravity at
                           !   mean sea level (=9.80665 m/s^2)

*....................................................................

!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
! BOP
!
! !ROUTINE: StdAtmZ - Computes 1976 standards atmospheric parameters at given geopotential height(s)
!
! !DESCRIPTION:
!     This routine computes and returns parameters for the 1976 standard
!     atmosphere at given geopotential height(s).
!
! !INTERFACE:
      pure subroutine StdAtmZ ( Z, P, T, R, alt )
!
! !INPUT PARAMETERS:
      implicit   NONE
      real,      intent (in),  dimension (:) ::
     .   Z     ! Height (in m)
      logical,   intent (in),  optional      ::
     .   alt   ! = .true. if Z is altitude.  Default: alt = .false.
!
! !OUTPUT PARAMETERS:
      real,      intent (out), dimension (:), optional ::
     .   P,    ! Pressure (in hPa or mb)
     .   T,    ! Absolute temperature (in deg K)
     .   R     ! Density of dry air (in Kg/m^3)
!
! !SEE ALSO:
!
! !REVISION HISTORY:
!     25Jun2001  C. Redder  Original code.
!     28Sep2001  C. Redder  Added units to parameter description in proglogue
!     10Oct2001  C. Redder  Made function pure
!     18Apr2002  C. Redder  Modified the method of determining the number of
!                           levels.
! EOP
!-------------------------------------------------------------------------

      logical :: geo, ReturnP, ReturnT, ReturnR
      real    :: Zkm, Zt, Ps, Ts, Rs, PP, TT, RR, TB, LR
      real    :: DeltaZ, ZConvF
      integer :: NLev, iLev, i, j, k, iLayer

!     Define ...
!     ----------
      Zt = tpzDef                     ! ... height at tropopause
      Ps = slpDef                     ! ... sea level pressure
      Ts = sltDef                     ! ... absolute temp at sea level
      Rs = slrDef                     ! ... sea level density

      geo     = .true.
      if ( present ( alt ) ) geo = .not. alt
      ReturnP = .false.
      if ( present ( P ) ) ReturnP = .true.
      ReturnT = .false.
      if ( present ( T ) ) ReturnT = .true.
      ReturnR = .false.
      if ( present ( R ) ) ReturnR = .true.

!     For each level ...
!     ------------------
      ZConvF = tpz_km / Zt
      NLev   = size ( Z )
      if ( ReturnP ) NLev = min ( NLev, size ( P ))
      if ( ReturnT ) NLev = min ( NLev, size ( T ))
      if ( ReturnR ) NLev = min ( NLev, size ( R ))
      do iLev = 1, NLev

!        Convert height to local (i.e. default) units
!        --------------------------------------------
         Zkm = ZConvF * Z ( iLev )

!        ... and, if necessary, to geopotential height
!        ---------------------------------------------
         if ( .not. geo ) Zkm = Zkm / ( 1.0 + Zkm / REarth )

!        Search for the correct layer
!        ----------------------------
         if      ( Zkm .lt. ZTab ( 2 ) ) then
            i = 1
         else if ( Zkm .lt. ZTab ( 3 ) ) then
            i = 2
         else if ( Zkm .lt. ZTab ( 4 ) ) then
            i = 3
         else if ( Zkm .lt. ZTab ( 5 ) ) then
            i = 4
         else if ( Zkm .gt. ZTab ( NLayers ) ) then
            i = NLayers
         else                    ! perform binary search for upper layers
            i = 5
            j = NLayers
            do iLayer = 1, NLayers
               k = ( i + j ) / 2 ! start from midpoint
               if ( Zkm .lt. ZTab ( k ) ) then
                  j = k
               else
                  i = k
               end if
               if ( j .le. i+1) exit
            end do
         end if

!        After the correct layer is found determine ...
!        ---------------------------------------------
         LR     = LTab ( i )                       ! ... lapse rate
         TB     = TTab ( i )                       ! ... base temp
         DeltaZ = Zkm - ZTab ( i )                 ! ... height above base
         TT     = TB + LR * DeltaZ                 ! ... local temp

!        ... pressure ratio within a layer of constant ...
!        -------------------------------------------------
         if ( nint ( LR * 1000.0 ) .eq. 0 ) then   ! ... temperature
            PP = PTab ( i ) * exp ( -GMR  * DeltaZ / TB )
         else                                      ! ... lapse rate
            PP = PTab ( i ) * ( TB / TT ) ** ( GMR / LR )
         end if

!        Return ...
!        ----------
         if ( ReturnP ) P ( iLev ) =   Ps * PP          ! ... pressure
         if ( ReturnT ) T ( iLev ) =   TT * Ts / slt_K  ! ... temp
         if ( ReturnR ) R ( iLev ) =   Rs * PP          ! ... density
     .                             / ( TT / slt_K )
      end do

      return
      end subroutine StdAtmZ
*....................................................................

!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
! BOP
!
! !ROUTINE: StdAtmP - Computes 1976 standard atmospheric parameters at given pressure level(s)
!
! !DESCRIPTION:
!     This routine computes and returns the parameters for the 1976
!     standard atmosphere at given pressure level(s).
!
! !INTERFACE:
      pure subroutine StdAtmP ( P, Z, T, R, alt )
!
! !INPUT PARAMETERS:
      implicit   NONE
      real,      intent (in),  dimension (:) ::
     .   P     ! Pressure (in hPa or mb)
      logical,   intent (in),  optional      ::
     .   alt   ! = .true. if Z is altitude.  Default: alt = .false.
!
! !OUTPUT PARAMETERS:
      real,      intent (out), dimension (:), optional ::
     .   Z,    ! Height (in m)
     .   T,    ! Absolute temperature (in deg K)
     .   R     ! Density of dry air (in Kg/m^3)
!
! !SEE ALSO:
!
! !REVISION HISTORY:
!
!     25Jun2001  C. Redder  Original code.
!     28Sep2001  C. Redder  Added units to parameter description in proglogue
!     10Oct2001  C. Redder  Made subroutine pure
!     18Apr2002  C. Redder  Modified the method of determining the number of
!                           levels.
!
! EOP
!-------------------------------------------------------------------------

      logical :: geo, ReturnZ, ReturnT, ReturnR
      real    :: Zkm, Zt, Ps, Ts, Rs, PP, TT, RR, TB, LR
      real    :: DeltaZ, ZConvF
      integer :: NLev, iLev, i, j, k, iLayer

!     Define ...
!     ----------
      Zt = tpzDef                     ! ... height at tropopause
      Ps = slpDef                     ! ... sea level pressure
      Ts = sltDef                     ! ... absolute temp at sea level
      Rs = slrDef                     ! ... sea level density
      geo     = .true.
      if ( present ( alt ) ) geo = .not. alt
      ReturnZ = .false.
      if ( present ( Z ) ) ReturnZ = .true.
      ReturnT = .false.
      if ( present ( T ) ) ReturnT = .true.
      ReturnR = .false.
      if ( present ( R ) ) ReturnR = .true.

!     For each level ...
!     ------------------
      ZConvF = Zt / tpz_km
      NLev   = size ( P )
      if ( ReturnZ ) NLev = min ( NLev, size ( Z ))
      if ( ReturnT ) NLev = min ( NLev, size ( T ))
      if ( ReturnR ) NLev = min ( NLev, size ( R ))
      do iLev = 1, NLev

!        Check pressure level ...
!        ------------------------
         if ( Ps .gt. 0 ) then
            PP = max ( P ( iLev ), 0.1 * Ps * PTab ( NLayers ) )
         else
            PP = min ( P ( iLev ), 0.1 * Ps * PTab ( NLayers ) )
         end if

!        ... and convert to pressure ratio
!        ---------------------------------
         PP    = PP / Ps

!        Search for the correct layer
!        ----------------------------
         if      ( PP .gt. PTab ( 2 ) ) then
            i = 1
         else if ( PP .gt. PTab ( 3 ) ) then
            i = 2
         else if ( PP .gt. PTab ( 4 ) ) then
            i = 3
         else if ( PP .gt. PTab ( 5 ) ) then
            i = 4
         else if ( PP .lt. PTab ( NLayers ) ) then
            i = NLayers
         else                    ! perform binary search for upper layers
            i = 5
            j = NLayers
            do iLayer = 1, NLayers
               k = ( i + j ) / 2 ! start from midpoint
               if ( PP .ge. PTab ( k ) ) then
                  j = k
               else
                  i = k
               end if
               if ( j .le. i+1) exit
            end do
         end if

!        After the correct layer is found determine ...
!        ---------------------------------------------
         LR = LTab ( i )                                ! ... lapse rate
         TB = TTab ( i )                                ! ... base temp

!        ... local temperature and height within the layer of constant ...
!        -----------------------------------------------------------------
         if ( nint ( LR * 1000.0 ) .eq. 0 ) then        ! ... temperature
            TT     =   TB
            DeltaZ =  -TB * log ( PP / PTab ( i ) ) / GMR
         else                                           ! ... lapse rate
            TT     = TTab ( i ) * ( PP / PTab ( i ) ) ** ( -LR / GMR )
            DeltaZ = ( TT - TB ) / LR
         end if
         Zkm = ZTab ( i ) + DeltaZ

!        If desired, convert to altitude
!        -------------------------------
         if ( .not. geo ) Zkm = Zkm / ( 1.0 - Zkm / REarth )

!        Return ...
!        ----------
         if ( ReturnZ ) Z ( iLev ) =   Zkm * ZConvF      ! ... height
         if ( ReturnT ) T ( iLev ) =   TT  * Ts / slt_K  ! ... temp
         if ( ReturnR ) R ( iLev ) =   Rs  * PP          ! ... density
     .                             / ( TT / sltDef )

      end do

      return
      end subroutine StdAtmP
*....................................................................
!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
! BOP
!
! !ROUTINE: StdZ2P - Computes pressure at a single height in the 1976 standard atmosphere
!
! !DESCRIPTION:
!     This routine computes and returns the pressure for the 1976
!     standard atmosphere at a single height.
!
! !INTERFACE:
      pure function StdZ2P ( Z, alt )
!
! !INPUT PARAMETERS:
      implicit   NONE
      real,      intent (in)            ::
     .   Z     ! Height (in m)
      logical,   intent (in),  optional ::
     .   alt   ! = .true. if Z is altitude.  Default: alt = .false.
!
! !OUTPUT PARAMETERS:
      real :: StdZ2P ! Pressure (in hPa or mb)
!
! !SEE ALSO:
!
! !REVISION HISTORY:
!
!     25Jun2001  Redder  Original code.
!     28Sep2001  Redder  Added units to parameter description in proglogue
!     10Oct2001  Redder  Made function pure
!
! EOP
!-------------------------------------------------------------------------
      real, dimension (1) :: P

      call StdAtmZ ( (/Z/), P, alt = alt )
      StdZ2P = P (1)

      end function StdZ2P
*....................................................................
!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
! BOP
!
! !ROUTINE: StdP2Z - Computes height at a single pressure level in the 1976 standard atmosphere
!
! !DESCRIPTION:
!     This routine computes and returns the height for the 1976 standard
!     atmosphere at a single pressure level.
!
! !INTERFACE:
      pure function StdP2Z ( P, alt )
!
! !INPUT PARAMETERS:
      implicit   NONE
      real,      intent (in)            ::
     .   P     ! Pressure (in hPa or mb)
      logical,   intent (in),  optional ::
     .   alt   ! = .true. if Z is altitude.  Default: alt = .false.
!
! !OUTPUT PARAMETERS:
      real :: StdP2Z ! Height (in m)
!
! !SEE ALSO:
!
! !REVISION HISTORY:
!
!     25Jun2001  Redder  Original code.
!     28Sep2001  Redder  Added units to parameter description in proglogue
!     10Oct2001  Redder  Made function pure
!
! EOP
!-------------------------------------------------------------------------
      real, dimension (1) :: Z

      call StdAtmP ( (/P/), Z, alt = alt )
      StdP2Z = Z (1)

      end function StdP2Z
*....................................................................
!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
! BOP
!
! !ROUTINE: StdZ2T - Computes temperature at a single height in the 1976 standard atmosphere
!
! !DESCRIPTION:
!     This routine computes and returns the temperature for the 1976
!     standard atmosphere at a single height.
!
! !INTERFACE:
      pure function StdZ2T ( Z, alt )
!
! !INPUT PARAMETERS:
      implicit   NONE
      real,      intent (in)            ::
     .   Z     ! Height (in m)
      logical,   intent (in),  optional ::
     .   alt   ! = .true. if Z is altitude.  Default: alt = .false.
!
! !OUTPUT PARAMETERS:
      real :: StdZ2T ! Temperature (in deg K)
!
! !SEE ALSO:
!
! !REVISION HISTORY:
!
!     28Sep2001  Redder  Original code.
!     10Oct2001  Redder  Made function pure
!
! EOP
!-------------------------------------------------------------------------
      real, dimension (1) :: T

      call StdAtmZ ( (/Z/), T = T, alt = alt )
      StdZ2T = T (1)

      end function StdZ2T
*....................................................................
!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
! BOP
!
! !ROUTINE: StdP2T - Computes temperature at a single pressure level in the 1976 standard atmosphere
!
! !DESCRIPTION:
!     This routine computes and returns the temperature for the 1976 standard
!     atmosphere at a single pressure level.
!
! !INTERFACE:
      pure function StdP2T ( P )
!
! !INPUT PARAMETERS:
      implicit   NONE
      real,      intent (in)            ::
     .   P     ! Pressure (in hPa or mb)
!
! !OUTPUT PARAMETERS:
      real :: StdP2T ! Temperature (in deg K)
!
! !SEE ALSO:
!
! !REVISION HISTORY:
!
!     28Sep2001  Redder  Original code.
!     10Oct2001  Redder  Made function pure
!
! EOP
!-------------------------------------------------------------------------
      real, dimension (1) :: T

      call StdAtmP ( (/P/), T = T )
      StdP2T = T (1)

      end function StdP2T
*....................................................................
!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
! BOP
!
! !ROUTINE: StdZ2R - Computes air density at a single height in the 1976 standard atmosphere
!
! !DESCRIPTION:
!     This routine computes and returns the density of dry air for the
!     1976 standard atmosphere at a single height.
!
! !INTERFACE:
      pure function StdZ2R ( Z, alt )
!
! !INPUT PARAMETERS:
      implicit   NONE
      real,      intent (in)            ::
     .   Z     ! Height (in m )
      logical,   intent (in),  optional ::
     .   alt   ! = .true. if Z is altitude.  Default: alt = .false.
!
! !OUTPUT PARAMETERS:
      real :: StdZ2R ! Density of dry air (in Kg/m^3)
!
! !SEE ALSO:
!
! !REVISION HISTORY:
!
!     28Sep2001  Redder  Original code.
!     10Oct2001  Redder  Made function pure
!
! EOP
!-------------------------------------------------------------------------
      real, dimension (1) :: R

      call StdAtmZ ( (/Z/), R = R, alt = alt )
      StdZ2R = R (1)

      end function StdZ2R
*....................................................................
!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
! BOP
!
! !ROUTINE: StdP2R - Computes air density at a single pressure level in the 1976 standard atmosphere
!
! !DESCRIPTION:
!     This routine computes and returns the density of dry air for the
!     1976 standard atmosphere at a single pressure level.
!
! !INTERFACE:
      pure function StdP2R ( P )
!
! !INPUT PARAMETERS:
      implicit   NONE
      real,      intent (in)            ::
     .   P     ! Pressure (in hPa or mb)
!
! !OUTPUT PARAMETERS:
      real :: StdP2R ! Density of dry air (in Kg/m^3)
!
! !SEE ALSO:
!
! !REVISION HISTORY:
!
!     28Sep2001  Redder  Original code.
!     10Oct2001  Redder  Made function pure
!
! EOP
!-------------------------------------------------------------------------
      real, dimension (1) :: R

      call StdAtmP ( (/P/), R = R )
      StdP2R = R (1)

      end function StdP2R
*....................................................................
      end module m_StdAtm
!====================================================================


!> \brief implements simplex algorithm for minimization in the spiriti of NR
!> \author Alin M Elena
!> \date 12th of November 2007
module m_Simplex
  use m_Constants
  use m_Types
  use m_Useful
  implicit none
  private
!
  public :: amoeba
!
contains
!> \brief minimization of the function func in n dimensions by the downhill simplex method
!> \details of nelder and mead. the (n + 1)Xn matrix p is input. its n + 1 rows are n-dimensional
!> vectors that are the vertices of the starting simplex. also input is the vector y of length
!> n + 1, whose components must be preinitialized to the values of func evaluated at the
!> n + 1 vertices (rows) of p;and ftol the fractional convergence tolerance to be achieved
!> in the function value (n.b.!). on output, p and y will have been reset to n +1 new points
!> all within ftol of a minimum function value, and iter gives the number of function
!> evaluations taken.
!> \date 12th of November 2007
!> \param p matrix n+1 by n contains the initial simplex
!> \param y array, n+1, contains the cost function for each point in simplex
!> @param func function the cost function
!> \param bounds array array, n, the parameters to be optimized
!> \param iter integer number of iterations done
!> \param itmax integer maximum number of iterations
!> \param ftol real the desired tolerance
!> \param io type(ioType) contains all the info about I/O files
!> \param gen type(generalType) contains the info needed by the program to run
!> \param atomic type(atomicxType) contains all info about the atoms and basis set and some parameters
!> \param tb type(modelType) contains information about the tight binding model parameters
!> \param sol type(solutionType) contains information about the solution space
!> \remarks all the job is done by AmoebaPrivate
!> \internal add citation to the original paper
  subroutine amoeba (p, y, ftol, func, iter, bounds, itmax, gen, atomic, tb, sol, io)
    character (len=*), parameter :: myname = "Amoeba"
    integer, intent (out) :: iter
    real (k_pr), intent (in) :: ftol
    real (k_pr), dimension (:), intent (inout) :: y
    real (k_pr), dimension (:, :), intent (inout) :: p
    real (k_pr), dimension (:, :), intent (in) :: bounds
    type (generalType), intent (inout) :: gen
    type (atomicxType), intent (inout) :: atomic
    type (modelType), intent (inout) :: tb
    type (solutionType), intent (inout) :: sol
    type (ioType), intent (inout) :: io
    integer, intent (in) :: itmax
    interface
      function func (x, gen, atomic, tb, sol, io)
        use m_Constants
        use m_Types
        implicit none
        real (k_pr), dimension (:), intent (in) :: x
        type (generalType), intent (inout) :: gen
        type (atomicxType), intent (inout) :: atomic
        type (modelType), intent (inout) :: tb
        type (solutionType), intent (inout) :: sol
        type (ioType), intent (inout) :: io
        real (k_pr) :: func
      end function func
    end interface
!
    real (k_pr), parameter :: tiny = 1.0e-10
    integer :: ihi, ndim !global variables.
    real (k_pr), dimension (size(p, 2)) :: psum
    call AmoebaPrivate
!
  contains
!
    subroutine AmoebaPrivate
      implicit none
      character (len=*), parameter :: myname = "AmoebaPrivate"
      integer :: i, ilo, inhi, iii
      real (k_pr) :: rtol, ysave, ytry, ytmp
      ndim = AssertEq (size(p, 2), size(p, 1)-1, size(y)-1, io)
      iter = 0
      psum (:) = sum (p(:, :), dim=1)
      do
        ilo = iminloc (y(:))!determine which point is the highest (worst),
        ihi = imaxloc (y(:))!next-highest, and lowest (best).
        ytmp = y (ihi)
        y (ihi) = y (ilo)
        inhi = imaxloc (y(:))
        y (ihi) = ytmp
        rtol = 2.0_k_pr * Abs (y(ihi)-y(ilo)) / (Abs(y(ihi))+Abs(y(ilo))+tiny)
!  rtol=abs(y(ihi)-y(ilo))
!compute the fractional range from highest to lowest and return if satisfactory.
        if (rtol < ftol) then !if returning, put best point and value in slot 1
          call swap (y(1), y(ilo))
          call swap (p(1, :), p(ilo, :))
          return
        end if
        if (iter >= itmax) then
          call error ("itmax achieved in amoeba", myname, .false., io)
          return
        end if
! begin a new iteration. first extrapolate by a factor ?1 through the face of the simplex
! across from the high point, i.e., reflect the simplex from the high point.
        ytry = amotry (-1.0_k_pr)
        iter = iter + 1
        if (ytry <= y(ilo)) then
!gives a result better than the best point, so
!try an additional extrapolation by a factor of 2.
          ytry = amotry (2.0_k_pr)
          iter = iter + 1
        else if (ytry >= y(inhi)) then
!the reflected point is worse than the second
!highest, so look for an intermediate lower point, i.e., do a one-dimensional contraction.
          ysave = y (ihi)
          ytry = amotry (0.5_k_pr)
          iter = iter + 1
          if (ytry >= ysave) then
!can't seem to get rid of that high point. better contract around the lowest (best) point.
            p (:, :) = 0.5_k_pr * (p(:, :)+spread(p(ilo, :), 1, size(p, 1)))
            do i = 1, ndim + 1
              if (i /= ilo) then
                y (i) = func (p(i, :), gen, atomic, tb, sol, io)
!!! check the bounds
                do iii = 1, ndim
                  if ((p(i, iii) < bounds(iii, 1)) .or. (p(i, iii) > bounds(iii, 2))) then
                    y (i) = k_infinity
                  end if
                end do
              end if
            end do
            iter = iter + ndim !keep track of function evaluations.
            psum (:) = sum (p(:, :), dim=1)
          end if
        end if
      end do !go back for the test of doneness and the next
    end subroutine AmoebaPrivate
!> \brief generates a new point in the simplex
!> \details extrapolates by a factor fac through the face of the simplex across from the high point,
!> tries it, and replaces the high point if the new point is better.
!> \author Alin M Elena
!> \date 12th of November 2007
!> \param fac real the factpor used in extrapolation
    function amotry (fac)
      character (len=*), parameter :: myname = "AmoTry"
      real (k_pr), intent (in) :: fac
      real (k_pr) :: amotry
      integer :: ii
!
      real (k_pr) :: fac1, fac2, ytry
      real (k_pr), dimension (size(p, 2)) :: ptry
      fac1 = (1.0_k_pr-fac) / ndim
      fac2 = fac1 - fac
      ptry (:) = psum (:) * fac1 - p (ihi, :) * fac2
      ytry = func (ptry, gen, atomic, tb, sol, io)!evaluate the function at the trial point.
!!! check the bounds
      do ii = 1, ndim
        if ((ptry(ii) < bounds(ii, 1)) .or. (ptry(ii) > bounds(ii, 2))) then
          ytry = k_infinity
        end if
      end do
      if (ytry < y(ihi)) then !if it's better than the highest, then replace
        y (ihi) = ytry !the highest.
        psum (:) = psum (:) - p (ihi, :) + ptry (:)
        p (ihi, :) = ptry (:)
      end if
      amotry = ytry
    end function amotry
  end subroutine amoeba
end module m_Simplex


PROGRAM claw_test
 INTEGER :: istart = 0
 INTEGER :: iend = 10
 INTEGER :: jstart = 0
 INTEGER :: jend = 20

 CALL call_test ( istart , iend , jstart , jend )
END PROGRAM claw_test

PURE FUNCTION f ( i , j )
 INTEGER , INTENT(IN) :: i
 INTEGER , INTENT(IN) :: j
 REAL :: f

 f = 1.0 * i * j
END FUNCTION f

SUBROUTINE call_test ( istart , iend , jstart , jend )

 INTEGER , INTENT(IN) :: istart
 INTEGER , INTENT(IN) :: iend
 INTEGER , INTENT(IN) :: jstart
 INTEGER , INTENT(IN) :: jend
 INTEGER :: i
 INTEGER :: j
 REAL :: array6 ( istart : iend , istart : iend )
 REAL :: array7 ( istart : iend , istart : iend )

 DO i = istart , iend , 1
  DO j = jstart , jend , 1
   array6 ( i , j ) = 1.0 * i * j
  END DO
 END DO
 DO i = istart , iend , 1
  DO j = jstart , jend , 1
   array7 ( i , j ) = f ( i , j ) * 2.0
  END DO
 END DO
 DO i = istart , iend , 1
  DO j = jstart , jend , 1
!$claw call array6=f(i,j) target(cpu)
   array7 ( i , j ) = array6 ( i , j ) * 2.0
  END DO
 END DO
END SUBROUTINE call_test


module vegetables_assert_equals_within_relative_m
    use iso_varying_string, only: varying_string, operator(//), var_str
    use strff, only: to_string
    use vegetables_messages_m, only: &
            make_within_failure_message, &
            make_within_success_message, &
            with_user_message
    use vegetables_result_m, only: result_t, fail, succeed
    use vegetables_utilities_m, only: equals_within_relative

    implicit none
    private
    public :: assert_equals_within_relative

    interface assert_equals_within_relative
        module procedure assert_equals_within_relative_basic
        module procedure assert_equals_within_relative_with_message_c
        module procedure assert_equals_within_relative_with_message_s
        module procedure assert_equals_within_relative_with_messages_cc
        module procedure assert_equals_within_relative_with_messages_cs
        module procedure assert_equals_within_relative_with_messages_sc
        module procedure assert_equals_within_relative_with_messages_ss
    end interface
contains
    pure function assert_equals_within_relative_basic( &
            expected, &
            actual, &
            tolerance) &
            result(result__)
        double precision, intent(in) :: expected
        double precision, intent(in) :: actual
        double precision, intent(in) :: tolerance
        type(result_t) :: result__

        result__ = assert_equals_within_relative( &
                expected, &
                actual, &
                tolerance, &
                var_str(""), &
                var_str(""))
    end function

    pure function assert_equals_within_relative_with_message_c( &
            expected, &
            actual, &
            tolerance, &
            message) &
            result(result__)
        double precision, intent(in) :: expected
        double precision, intent(in) :: actual
        double precision, intent(in) :: tolerance
        character(len=*), intent(in) :: message
        type(result_t) :: result__

        result__ = assert_equals_within_relative( &
                expected, &
                actual, &
                tolerance, &
                var_str(message), &
                var_str(message))
    end function

    pure function assert_equals_within_relative_with_message_s( &
            expected, &
            actual, &
            tolerance, &
            message) &
            result(result__)
        double precision, intent(in) :: expected
        double precision, intent(in) :: actual
        double precision, intent(in) :: tolerance
        type(varying_string), intent(in) :: message
        type(result_t) :: result__

        result__ = assert_equals_within_relative( &
                expected, &
                actual, &
                tolerance, &
                message, &
                message)
    end function

    pure function assert_equals_within_relative_with_messages_cc( &
            expected, &
            actual, &
            tolerance, &
            success_message, &
            failure_message) &
            result(result__)
        double precision, intent(in) :: expected
        double precision, intent(in) :: actual
        double precision, intent(in) :: tolerance
        character(len=*), intent(in) :: success_message
        character(len=*), intent(in) :: failure_message
        type(result_t) :: result__

        result__ = assert_equals_within_relative( &
                expected, &
                actual, &
                tolerance, &
                var_str(success_message), &
                var_str(failure_message))
    end function

    pure function assert_equals_within_relative_with_messages_cs( &
            expected, &
            actual, &
            tolerance, &
            success_message, &
            failure_message) &
            result(result__)
        double precision, intent(in) :: expected
        double precision, intent(in) :: actual
        double precision, intent(in) :: tolerance
        character(len=*), intent(in) :: success_message
        type(varying_string), intent(in) :: failure_message
        type(result_t) :: result__

        result__ = assert_equals_within_relative( &
                expected, &
                actual, &
                tolerance, &
                var_str(success_message), &
                failure_message)
    end function

    pure function assert_equals_within_relative_with_messages_sc( &
            expected, &
            actual, &
            tolerance, &
            success_message, &
            failure_message) &
            result(result__)
        double precision, intent(in) :: expected
        double precision, intent(in) :: actual
        double precision, intent(in) :: tolerance
        type(varying_string), intent(in) :: success_message
        character(len=*), intent(in) :: failure_message
        type(result_t) :: result__

        result__ = assert_equals_within_relative( &
                expected, &
                actual, &
                tolerance, &
                success_message, &
                var_str(failure_message))
    end function

    pure function assert_equals_within_relative_with_messages_ss( &
            expected, &
            actual, &
            tolerance, &
            success_message, &
            failure_message) &
            result(result__)
        double precision, intent(in) :: expected
        double precision, intent(in) :: actual
        double precision, intent(in) :: tolerance
        type(varying_string), intent(in) :: success_message
        type(varying_string), intent(in) :: failure_message
        type(result_t) :: result__

        if (equals_within_relative(expected, actual, tolerance)) then
            result__ = succeed(with_user_message( &
                    make_within_success_message( &
                            to_string(expected), &
                            to_string(actual), &
                            to_string(tolerance * 100.0d0) // "%"), &
                    success_message))
        else
            result__ = fail(with_user_message( &
                    make_within_failure_message( &
                            to_string(expected), &
                            to_string(actual), &
                            to_string(tolerance * 100.0d0) // "%"), &
                    failure_message))
        end if
    end function
end module


SUBROUTINE zbrak(func,x1,x2,n,xb1,xb2,fb1,fb2,nbb)
!returns the nb brackets in the first nb positions in xb1, xb2
! and the associated function values in fb1,fb2
! if no solutions returns function values at x1 and x2 in fb1(1),fb2(1)
USE Params
USE Globals

IMPLICIT NONE
INTEGER, INTENT(IN) :: n
INTEGER, INTENT(OUT) :: nbb
double precision, INTENT(IN) :: x1,x2
double precision, INTENT(OUT) :: xb1(n),xb2(n),fb1(n),fb2(n)
double precision, EXTERNAL	:: func

INTEGER :: i
double precision :: dx
double precision, DIMENSION(0:n) :: f,x
LOGICAL, DIMENSION(1:n) :: mask

dx=(x2-x1)/real(n)
x(0) = x1
do i = 1,n
	x(i) = x(i-1)+dx
end do
do i=0,n
	f(i)=func(x(i))
!	write(*,*) x(i),f(i),gass
end do

mask=f(1:n)*f(0:n-1) <= 0.0
nbb=count(mask)
if(nb>0) then
	xb1(1:nbb)=pack(x(0:n-1),mask)
	xb2(1:nbb)=pack(x(1:n),mask)
	fb1(1:nbb)=pack(f(0:n-1),mask)
	fb2(1:nbb)=pack(f(1:n),mask)
else
	fb1(1) = f(0)
	fb2(1) = f(n)
	xb1(1) = x1
	xb2(1) = x2
!	write(*,*) 'x',x
!	write(*,*) 'f',f
end if

END SUBROUTINE zbrak


!-----------------------------------------------------------------------
! SSE vector add test program
! written by Viktor K. Decyk, UCLA
! nx = size of array
      program ssetest
      use iso_c_binding
      use sselib_c
      implicit none
      integer :: nx = 1048576
      integer :: j, irc = 0
      real :: eps, epsmax
! timing data
      double precision :: dtime
      integer, dimension(4) :: itime
! data for Fortran
      real, dimension(:), allocatable :: a, b, c
! data for SSE
      real, dimension(:), pointer :: s_a => null()
      real, dimension(:), pointer :: s_b => null()
      real, dimension(:), pointer :: s_c => null()
!
! initialize Fortran data
      allocate(a(nx),b(nx),c(nx))
! initialize vectors
      a = 0.0
      do j = 1, nx
         b(j) = j
         c(j) = 2*j
      enddo
! allocate aligned 1d array for SSE
      call sse_f1allocate(s_a,nx,irc)
      call sse_f1allocate(s_b,nx,irc)
      call sse_f1allocate(s_c,nx,irc)
      if (irc /= 0) then
         write (*,*) 'SSE allocate error!'
         stop
      endif
! Copy initial data for SSE
      s_b = b; s_c = c
!
! First execute in Fortran: a = b + c
      call dtimer(dtime,itime,-1)
      call fadd(a,b,c,nx)
      call dtimer(dtime,itime,1)
      write (*,*) 'Fortran add time=', real(dtime)
!
! Execute on SSE: s_a = s_b + s_c
      call dtimer(dtime,itime,-1)
      call fssadd(s_a,s_b,s_c,nx)
      call dtimer(dtime,itime,1)
      write (*,*) 'SSE add time=', real(dtime)
!
! Check for correctness: compare a and s_a
      epsmax = 0.0
      do j = 1, nx
         eps = abs(a(j)-s_a(j))
         if (eps > epsmax) epsmax = eps
      enddo
      write (*,*) 'maximum difference = ', epsmax
!
! deallocate memory for SSE
      call sse_deallocate(c_loc(s_a(1)),irc); nullify(s_a)
      call sse_deallocate(c_loc(s_b(1)),irc); nullify(s_b)
      call sse_deallocate(c_loc(s_c(1)),irc); nullify(s_c)
! deallocate Fortran memory
      deallocate(a,b,c)
!
      end program
!
      subroutine fadd(a,b,c,nx)
! Fortran add procedure
      integer :: nx
      real, dimension(nx) :: a, b, c
      integer :: j
      do j = 1, nx
         a(j) = b(j) + c(j)
      enddo
      end subroutine


! { dg-do run }
!
! PR 40996: [F03] ALLOCATABLE scalars
!
! Contributed by Janus Weil <janus@gcc.gnu.org>

implicit none
real, allocatable :: scalar

allocate(scalar)
scalar = exp(1.)
print *,scalar
if (.not. allocated(scalar)) call abort()
deallocate(scalar)
if (allocated(scalar)) call abort()

end


! { dg-do run }
! PR59771 Cleanup handling of Gw.0 and Gw.0Ee format
! Test case prepared by Dominique d'Humieres <dominiq@lps.ens.fr>
       PROGRAM FOO
       character(len=60) :: buffer, buffer1

       write (buffer ,'(6(1X,1PG9.0e2))') 0.0, 0.04, 0.06, 0.4, 0.6, 243.0
       write (buffer1,'(6(1X,1PE9.0e2))') 0.0, 0.04, 0.06, 0.4, 0.6, 243.0

       if (buffer /= buffer1) call abort
       end


PROGRAM test_type_extension
!
!  Purpose:
!    To illustrate type extension of derived data types.
!
!  Record of revisions:
!       Date       Programmer          Description of change
!       ====       ==========          =====================
!     12/04/06    S. J. Chapman        Original code
!
IMPLICIT NONE

! Declare type point
TYPE :: point
   REAL :: x
   REAL :: y
END TYPE

! Declare type point3d
TYPE, EXTENDS(point) :: point3d
   REAL :: z
END TYPE

! Declare a variable of type person:
TYPE (point3d) :: my_point

! Initialize variable
my_point%x = 1.
my_point%y = 2.
my_point%z = 3.

! Output variable using free format I/O
WRITE (*,*) 'my_point = ', my_point

END PROGRAM test_type_extension


*DECK BALANC
      SUBROUTINE BALANC (NM, N, A, LOW, IGH, SCALE)
C***BEGIN PROLOGUE  BALANC
C***PURPOSE  Balance a real general matrix and isolate eigenvalues
C            whenever possible.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C1A
C***TYPE      SINGLE PRECISION (BALANC-S, CBAL-C)
C***KEYWORDS  EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure BALANCE,
C     NUM. MATH. 13, 293-304(1969) by Parlett and Reinsch.
C     HANDBOOK FOR AUTO. COMP., Vol.II-LINEAR ALGEBRA, 315-326(1971).
C
C     This subroutine balances a REAL matrix and isolates
C     eigenvalues whenever possible.
C
C     On INPUT
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameter, A, as declared in the calling program
C          dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix A.  N is an INTEGER variable.
C          N must be less than or equal to NM.
C
C        A contains the input matrix to be balanced.  A is a
C          two-dimensional REAL array, dimensioned A(NM,N).
C
C     On OUTPUT
C
C        A contains the balanced matrix.
C
C        LOW and IGH are two INTEGER variables such that A(I,J)
C          is equal to zero if
C           (1) I is greater than J and
C           (2) J=1,...,LOW-1 or I=IGH+1,...,N.
C
C        SCALE contains information determining the permutations and
C          scaling factors used.  SCALE is a one-dimensional REAL array,
C          dimensioned SCALE(N).
C
C     Suppose that the principal submatrix in rows LOW through IGH
C     has been balanced, that P(J) denotes the index interchanged
C     with J during the permutation step, and that the elements
C     of the diagonal matrix used are denoted by D(I,J).  Then
C        SCALE(J) = P(J),    for J = 1,...,LOW-1
C                 = D(J,J),      J = LOW,...,IGH
C                 = P(J)         J = IGH+1,...,N.
C     The order in which the interchanges are made is N to IGH+1,
C     then 1 TO LOW-1.
C
C     Note that 1 is returned for IGH if IGH is zero formally.
C
C     The ALGOL procedure EXC contained in BALANCE appears in
C     BALANC  in line.  (Note that the ALGOL roles of identifiers
C     K,L have been reversed.)
C
C     Questions and comments should be directed to B. S. Garbow,
C     Applied Mathematics Division, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BALANC
C
      INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
      REAL A(NM,*),SCALE(*)
      REAL C,F,G,R,S,B2,RADIX
      LOGICAL NOCONV
C
C***FIRST EXECUTABLE STATEMENT  BALANC
      RADIX = 16
C
      B2 = RADIX * RADIX
      K = 1
      L = N
      GO TO 100
C     .......... IN-LINE PROCEDURE FOR ROW AND
C                COLUMN EXCHANGE ..........
   20 SCALE(M) = J
      IF (J .EQ. M) GO TO 50
C
      DO 30 I = 1, L
         F = A(I,J)
         A(I,J) = A(I,M)
         A(I,M) = F
   30 CONTINUE
C
      DO 40 I = K, N
         F = A(J,I)
         A(J,I) = A(M,I)
         A(M,I) = F
   40 CONTINUE
C
   50 GO TO (80,130), IEXC
C     .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
C                AND PUSH THEM DOWN ..........
   80 IF (L .EQ. 1) GO TO 280
      L = L - 1
C     .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
  100 DO 120 JJ = 1, L
         J = L + 1 - JJ
C
         DO 110 I = 1, L
            IF (I .EQ. J) GO TO 110
            IF (A(J,I) .NE. 0.0E0) GO TO 120
  110    CONTINUE
C
         M = L
         IEXC = 1
         GO TO 20
  120 CONTINUE
C
      GO TO 140
C     .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
C                AND PUSH THEM LEFT ..........
  130 K = K + 1
C
  140 DO 170 J = K, L
C
         DO 150 I = K, L
            IF (I .EQ. J) GO TO 150
            IF (A(I,J) .NE. 0.0E0) GO TO 170
  150    CONTINUE
C
         M = K
         IEXC = 2
         GO TO 20
  170 CONTINUE
C     .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
      DO 180 I = K, L
  180 SCALE(I) = 1.0E0
C     .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
  190 NOCONV = .FALSE.
C
      DO 270 I = K, L
         C = 0.0E0
         R = 0.0E0
C
         DO 200 J = K, L
            IF (J .EQ. I) GO TO 200
            C = C + ABS(A(J,I))
            R = R + ABS(A(I,J))
  200    CONTINUE
C     .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
         IF (C .EQ. 0.0E0 .OR. R .EQ. 0.0E0) GO TO 270
         G = R / RADIX
         F = 1.0E0
         S = C + R
  210    IF (C .GE. G) GO TO 220
         F = F * RADIX
         C = C * B2
         GO TO 210
  220    G = R * RADIX
  230    IF (C .LT. G) GO TO 240
         F = F / RADIX
         C = C / B2
         GO TO 230
C     .......... NOW BALANCE ..........
  240    IF ((C + R) / F .GE. 0.95E0 * S) GO TO 270
         G = 1.0E0 / F
         SCALE(I) = SCALE(I) * F
         NOCONV = .TRUE.
C
         DO 250 J = K, N
  250    A(I,J) = A(I,J) * G
C
         DO 260 J = 1, L
  260    A(J,I) = A(J,I) * F
C
  270 CONTINUE
C
      IF (NOCONV) GO TO 190
C
  280 LOW = K
      IGH = L
      RETURN
      END


      SUBROUTINE EQUI_SPLINE(IBUF,A,B,C,N)
      INTEGER*2 IBUF(1)
      REAL A(N),B(N),C(N)
C
C-----CUBIC SPLINE COEFFICIENTS FOR EQUIDISTANT INTERVALS
      DO 10 I=2,N-1
      B(I)=.5
   10 C(I)=3.*(IBUF(I+1)-2.*IBUF(I)+IBUF(I-1))
      B(2)=2.
C
      DO 20 I=3,N-1
      X=B(I)/B(I-1)
      B(I)=2.-.5*X
   20 C(I)=C(I)-X*C(I-1)
      C(N-1)=C(N-1)/B(N-1)
      DO 30 I=N-2,2,-1
   30 C(I)=(C(I)-.5*C(I+1))/B(I)
      C(1)=.0
      C(N)=.0
C
      DO 40 I=1,N-1
      A(I)=IBUF(I+1)-IBUF(I)-(2.*C(I)+C(I+1))/6.
      B(I)=.5*C(I)
   40 C(I)=(C(I+1)-C(I))/6.
C
      RETURN
      END


!  VERSION 1.0  (NLSPMC version)   2/5/99
!**********************************************************************
!                         ====================
!                           subroutine ANXLK
!                         ====================

!       This subroutine calculates the xlk coefficients for
!       the potential-dependent part of the diffusion operator
!       for use in the SLE matrix calculation (MATRL, MATRF).
!       Array xlk (in /eprdat/) should be dimensioned to at least
!       (5,5), so that it can accommodate even L,K values from 0
!       to 8 (twice the highest possible L of a potential coefficient)

!       Notes:
!          The summation over the X(L,K)'s proceeds from 0 to 2*lptmx
!          X(L,K) is nonzero only for even L,K
!          X(L,K) = X(L,-K)  [similar to potential coefficients]

!          This code has been updated to include the possibility of a
!          nonaxial diffusion tensor (Rx .ne. Ry .ne. Rz). It was
!          developed from subroutine CALXLK by D.J. Schneider which was
!          based on the original subroutine matr written by G.Moro.

!       written by DEB 8-JUL-92

!       Includes:
!               nlsdim.inc
!               eprprm.inc
!               rndoff.inc

!       Uses:
!               w3j.f

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

    subroutine anxlk(ipt,lptmx,kptmx,cpot,rp,rm,rz,xlk)
    implicit none

!    include 'limits.inc'
!    include 'simparm.inc'
    include 'rndoff.inc'

    double precision :: rp,rm,rz

    integer :: k,kx,kptf,k1f,k1i,k1,k1abs,k1x,k2,k2abs,k2f,k2i,k2x, &
    l,lx,l1,l1x,l2,l2x
    double precision :: factl,wig1,rj2u,rjuju,term

    double precision :: w3j
    external w3j

!######################################################################
!   new parameters added
    double precision :: xlk(5,5), cpot(5,5)
    integer          :: ipt, lptmx, kptmx

!    write(*,*) 'anxlk: cpot(2,1)=',cpot(2,1)
!    write(*,*) 'lptmx, kptmx:', lptmx, kptmx
!    write(*,*) 'rp,rm,rz:', rp,rm,rz

    do 20 lx=1,5
        do 10 kx=1,5
            xlk(lx,kx)=0.0D0
        10 END DO
    20 END DO

!----------------------------------------------------------------------
!     exit if no potential
!----------------------------------------------------------------------
!    write(*,*) 'ipt=',ipt
    if(ipt == 0) return

!---------------------------------------------------------------------
!     calculate xlk coefficients
!----------------------------------------------------------------------

! --- loop over L

    do 100 l=0,lptmx*2,2
        lx=1+l/2
        factl=dble(2*l+1)
        kptf=min(l,2*kptmx+2)

    ! --- loop over K ---

        do 90 k=0,kptf,2
            kx=1+k/2

        !------------------------------
        !         (J*R*J)U term
        !------------------------------

            rj2u=cpot(lx,kx)*( rp*dble(l*(l+1)-k*k) + rz*dble(k*k) )
            if (k+2 <= l .AND. k+2 <= kptmx) rj2u=rj2u+rm*cpot(lx,kx+1) &
            * dsqrt(dble((l+k+1)*(l+k+2)*(l-k-1)*(l-k) ) )
            if (k-2 >= 0) rj2u=rj2u+rm*cpot(lx,kx-1) &
            * dsqrt(dble((l-k+1)*(l-k+2)*(l+k-1)*(l+k) ) )
            if (k-2 < 0) rj2u=rj2u+rm*cpot(lx,kx+1) &
            * dsqrt(dble((l-k+1)*(l-k+2)*(l+k-1)*(l+k) ) )
            xlk(lx,kx)=-0.5d0*rj2u

        !------------------------------
        !      (JU)*R*(JU) term
        !------------------------------

            rjuju = 0.0d0

        !      --- loop over L1

            do 80 l1=0,lptmx,2
                l1x=1+l1/2
                k1f=min(l1,kptmx)
                k1i=-k1f

            !        --- loop over L2

                do 70 l2=0,lptmx,2
                    l2x=1+l2/2
                    if(l1+l2 >= l) then
                        wig1=w3j(l1,l,l2,0,0,0)
                    else
                        wig1=0.0D0
                        go to 70
                    end if

                !         --- loop over K1

                    do 60 k1=k1i,k1f,2
                        k1abs=abs(k1)
                        k1x=1+k1abs/2

                    !        ---- loop over K2

                        k2i=max(k-k1-2,-kptmx,-l2)
                        k2f=min(k-k1+2,kptmx,l2)

                        do 50 k2=k2i,k2f,2
                            k2abs=abs(k2)
                            k2x=1+k2abs/2

                        !        ------- (J_+ U)(J_+ U) term

                            if( (k2 == k-k1-2) .AND. (abs(k1+1) <= l1) &
                             .AND. (abs(k2+1) <= l2) ) then
                                term=rm*w3j(l1,l,l2,k1+1,-k,k2+1)* dsqrt( &
                                dble((l1-k1)*(l1+k1+1)*(l2-k2)*(l2+k2+1)) )

                            !       ------- (J_- U)(J_- U) term

                            else if ( (k2 == k-k1+2) .AND. (abs(k1-1) <= l1) &
                                 .AND. (abs(k2-1) <= l2) ) then
                                term=rm*w3j(l1,l,l2,k1-1,-k,k2-1)* dsqrt( &
                                dble((l1+k1)*(l1-k1+1)*(l2+k2)*(l2-k2+1)) )

                            !      ------- (J_+ U)(J_- U) term

                            else if (k2 == k-k1) then
                                if((abs(k1+1) <= l1) .AND. (abs(k2-1) <= l2)) then
                                    term=rp*w3j(l1,l,l2,k1+1,-k,k2-1)* &
                                    dsqrt(dble((l1-k1)*(l1+k1+1)*(l2+k2)*(l2-k2+1)))
    !                                write(*,*) 'at least reaching the right location in (J_+)(J_-)', rp,&
    !                                                                            w3j(l1,l,l2,k1+1,-k,k2-1),&
    !                                                                            dsqrt(dble((l1-k1)*(l1+k1+1)*(l2+k2)*(l2-k2+1)))
                                else
                                    term=0.0D0
    !                                write(*,*) 'term got set to 0 in anxlk'
                                end if

                            !      ------ (Jz U)(Jz U) term

                                if (k2abs <= l2) &
                                term=term+rz*dble(k1*k2)*w3j(l1,l,l2,k1,-k,k2)

                            else
                                term=0.0d0
                            end if

                            rjuju=rjuju+cpot(l1x,k1x)*cpot(l2x,k2x)*wig1*term
 !                           write(*,*) 'term=', term
                        50 END DO
                    60 END DO
                70 END DO
            80 END DO
            xlk(lx,kx)=xlk(lx,kx)-0.25D0*factl*rjuju
 !           write(*,*) 'anxlk: factl, rjuju=', lx, kx, factl, rjuju
        90 END DO
    100 END DO

    do 120 lx=1,5
        do 110 kx=1,5
            if (abs(xlk(lx,kx)) < rndoff) xlk(lx,kx)=0.0D0
        110 END DO
    120 END DO

    return
    end subroutine anxlk


**==brems.spg  processed by SPAG 4.50J  at 14:49 on 30 Jun 1995
      SUBROUTINE BREMS(T,N)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL ABUnd , ABUnj , BINmin , BINsyz , BRMev , chrgsm , CONce ,
     &     DNE , ebk , en1 , en2 , exprod , FBG , GNDrec , hc , HENeut ,
     &     HEPlus , PCOol , PM , POT
      REAL POU , POWer , q , RE , RECev , RHY , T , t6 , TU , TUF , x ,
     &     y , z
      INTEGER i , i2 , j , j1 , j2 , N , NBIn , NJ
C*** End of declarations inserted by SPAG
      REAL kt

      INCLUDE 'rayspec.inc'

      COMMON /RESULT/ CONce(30) , GNDrec(30) , POWer(220) , RHY ,
     &                HENeut , HEPlus , DNE , PCOol , POU , POT , RE ,
     &                TU , PM(4)
      COMMON /PARAMS/ NJ(12) , ABUnj(12) , ABUnd , BINmin , BINsyz ,
     &                NBIn
      COMMON /CONTIN/ BRMev(MXBINS) , RECev(MXBINS) , TUF(MXBINS)
      DIMENSION x(30)
      hc = 12399.
      j2 = N + 1
      j1 = 2
      t6 = T/1.E6
      kt = 86.17*t6
      ebk = EXP(BINsyz/kt)
      q = 10.**(ABUnd-12.)*86.17*SQRT(t6)*20.4*(ebk-1.)*EXP(-BINmin/kt)
     &    /hc
      ebk = 1./ebk
      DO 100 j = j1 , j2
         x(j) = 0.
         IF ( CONce(j).GT.1.E-5 ) x(j) = CONce(j)*q*(j-1)**2
 100  CONTINUE
      i2 = MIN0(NBIn,INT(46.*kt/BINsyz)+1)
      exprod = 1.
      DO 200 i = 1 , i2
         en2 = BINsyz*i + BINmin
         en1 = en2 - BINsyz
         y = (en2+en1)*.5/kt
         chrgsm = 0.
         DO 150 j = j1 , j2
            IF ( x(j).NE.0. ) THEN
               z = (j-1)**2*.158/t6
               chrgsm = chrgsm + x(j)*FBG(y,z)
            ENDIF
 150     CONTINUE
         exprod = exprod*ebk
         BRMev(i) = BRMev(i) + chrgsm*exprod
 200  CONTINUE
      RETURN
      END


!
! Geopotential
!
! Module containing routines for calculating geopotential heights.
!
! CONTAINS:
!       Geopotential_Height:     Function to calculate the geopotential height
!                                for an input profile.
!
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 01-May-2000
!                       paul.vandelst@noaa.gov
!

MODULE Geopotential

  ! -----------------
  ! Environment setup
  ! -----------------
  ! Modules used
  USE Type_Kinds, ONLY: fp
  USE Message_Handler
  USE Atmospheric_Properties
  USE Profile_Utility_Parameters, ONLY: R0, G0, PI, &
                                        ZERO, ONE, TWO, TOLERANCE, &
                                        G_TO_KG
  ! Disable all implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  PRIVATE
  PUBLIC :: Geopotential_Height

  ! -----------------
  ! Module parameters
  ! -----------------
  CHARACTER(*), PARAMETER :: MODULE_RCS_ID = &
  ! Message string lengths
  INTEGER, PARAMETER :: ML = 256

CONTAINS

!################################################################################
!################################################################################
!##                                                                            ##
!##                         ## PUBLIC MODULE ROUTINES ##                       ##
!##                                                                            ##
!################################################################################
!################################################################################

!--------------------------------------------------------------------------------
!:sdoc+:
! NAME:
!       Geopotential_Height
!
! PURPOSE:
!       Function to calculate geopotential height using the hypsometric
!       equation.
!
! CALLING SEQUENCE:
!       Error_Status = Geopotential_Height( &
!                        Pressure                                           , &
!                        Temperature                                        , &
!                        Water_Vapor_Pressure                               , &
!                        Height                                             , &
!                        Surface_Height           = Surface_Height          , &
!                        Gravity_Correction       = Gravity_Correction      , &
!                        Latitude                 = Latitude                , &
!                        Zonal_Wind_Velocity      = Zonal_Wind_Velocity     , &
!                        Meridional_Wind_Velocity = Meridional_Wind_Velocity  )
!
! INPUTS:
!       Pressure:                  Pressure of the atmospheric levels.
!                                  UNITS:      hectoPascals, hPa
!                                  TYPE:       REAL(fp)
!                                  DIMENSION:  Rank-1 (K x 1)
!                                  ATTRIBUTES: INTENT(IN)
!
!       Temperature:               Temperature of the atmospheric levels.
!                                  UNITS:      Kelvin, K
!                                  TYPE:       REAL(fp)
!                                  DIMENSION:  Same as Pressure
!                                  ATTRIBUTES: INTENT(IN)
!
!       Water_Vapor_Pressure:      Water vapor partial pressure at the atmospheric levels
!                                  UNITS:      hectoPascals, hPa
!                                  TYPE:       REAL(fp)
!                                  DIMENSION:  Same as Pressure
!                                  ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       Height:                    Geopotential heights of the input Pressure levels.
!                                  UNITS:      metres, m
!                                  TYPE:       REAL(fp)
!                                  DIMENSION:  Same as input Pressure
!                                  ATTRIBUTES: INTENT(OUT)
!
! OPTIONAL INPUTS:
!       Surface_Height:            Height corresponding to the first element of the
!                                  input arrays. If not specified, the default value
!                                  is 0.0m.
!                                  UNITS:      metres, m.
!                                  TYPE:       REAL(fp)
!                                  DIMENSION:  Scalar
!                                  ATTRIBUTES: OPTIONAL, INTENT(IN)
!
!       Gravity_Correction:        Set this argument to use a gravity profile rather
!                                  than standard reference gravity in calculating
!                                  the geopotential heights.
!                                  If .FALSE. , standard gravity used [DEFAULT],
!                                     .TRUE.  , gravity profile is calculated and used.
!                                  UNITS:      N/A.
!                                  TYPE:       LOGICAL
!                                  DIMENSION:  Scalar
!                                  ATTRIBUTES: OPTIONAL, INTENT(IN)
!
!       Latitude:                  Set this argument to the Latitude corresponding
!                                  to the input profile location. This argument is
!                                  ignored if the Gravity_Correction argument is
!                                  NOT set. If not defined and required, the default
!                                  value is zero.
!                                  UNITS:      Degrees (no N or S hemisphere dep.).
!                                  TYPE:       REAL(fp)
!                                  DIMENSION:  Scalar
!                                  ATTRIBUTES: OPTIONAL, INTENT(IN)
!
!       Zonal_Wind_Velocity:       Set this argument to the zonal wind velocities
!                                  at the input profile levels. This argument is
!                                  ignored if the Gravity_Correction argument is
!                                  not set. If not specified, the default value
!                                  is zero.
!                                  UNITS:      m.s^-1, +ve W'ly, -ve E'ly
!                                  TYPE:       REAL(fp)
!                                  DIMENSION:  Same as Pressure
!                                  ATTRIBUTES: OPTIONAL, INTENT(IN)
!
!       Meridional_Wind_Velocity:  Set this argument to the meridional wind velocities
!                                  at the input profile levels. This argument is
!                                  ignored if the Gravity_Correction argument is
!                                  not set. If not specified, the default value
!                                  is zero.
!                                  UNITS:      m.s^-1, +ve S'ly, -ve N'ly
!                                  TYPE:       REAL(fp)
!                                  DIMENSION:  Same as Pressure
!                                  ATTRIBUTES: OPTIONAL, INTENT(IN)
!
! FUNCTION RESULT:
!       Error_Status:              The return value is an integer defining the
!                                  error status. The error codes are defined
!                                  in the Message_Handler module.
!                                  If == SUCCESS the calculation was successful
!                                     == FAILURE an unrecoverable error occurred
!                                  UNITS:      N/A
!                                  TYPE:       INTEGER
!                                  DIMENSION:  Scalar
!
! PROCEDURE:
!       Geopotential heights are calculated using the hypsometric equation:
!
!                   _   [  p1  ]
!         z2 - z1 = H.ln[ ---- ]     .....(1)
!                       [  p2  ]
!             _
!       where H     = scale height,
!             p1,p2 = layer boundary pressures, and
!             z1,z2 = layer boundary heights.
!
!       and
!
!         _    R_air * T
!         H = -----------     .....(2)
!                  g
!
!       where R_air = gas constant for moist air
!             T     = average temperature for an atmospheric layer,
!             g     = acceleration due to gravity
!
!       The gas constant for air is given by:
!
!                  1000 * R
!         R_air = ----------     .....(3)
!                   MW_air
!
!       where R0     = Molar gas constant
!             MW_air = Water vapor weighted molecular weight of air
!
!       and the factor of 1000 is for conversion of the molecular
!       weight from g.mol^-1 to kg.mol^-1.
!
!       Layer values for both R_air and T are determined from a density
!       weighted average of adjacent level values:
!
!                    X(k)*rho(k) + X(k-1)*rho(k-1)
!         layer_X = -------------------------------
!                         rho(k) + rho(k-1)
!
!       The use of an optional gravity profile was introduced to make
!       this code parallel that of the UMBC KLAYERS altitude calculation
!       code.
!
!       Units analysis:
!       ---------------
!
!       Typical units of the quantities are,
!
!         units(T)      = K
!         units(g)      = m.s^-2
!         units(R0)     = J.K^-1.mol^-1 = kg.m^2.s^-2.K^-1.mol^-1
!         units(MW_air) = g.mol^-1
!
!       From eqn(3),
!
!                         kg.m^2.s^-2.K^-1.mol^-1
!         units(R_air) = -------------------------
!                               g.mol^-1
!
!                         1000 kg.m^2.s^-2.K^-1.mol^-1
!                      = ------------------------------
!                                 kg.mol^-1
!
!                      = 1000 m^2.s^-2.K^-1
!
!       From eqn.(2),
!
!               _     1000 m^2.s^-2.K^-1 . K
!         units(H) = ------------------------
!                            m.s^-2
!
!                   = 1000 m
!
!       So the final heights must be multiplied by 1000 to get units of metres.
!
!
!       If you're wondering why I don't use the virtual temperature rather
!       than calculate MW_air and R_air, the reasons are two-fold:
!         1) To calculate a density using the ideal gas law, you need to
!            know either of these quantities, and
!         2) Eventually, the effect due to ozone will also be included.
!
!:sdoc-:
!--------------------------------------------------------------------------------

  FUNCTION Geopotential_Height( &
    Pressure                , &  ! Input
    Temperature             , &  ! Input
    Water_Vapor_Pressure    , &  ! Input
    Height                  , &  ! Output
    Surface_Height          , &  ! Optional input
    Gravity_Correction      , &  ! Optional input
    Latitude                , &  ! Optional input
    Zonal_Wind_Velocity     , &  ! Optional input
    Meridional_Wind_Velocity) &  ! Optional input
  RESULT( err_stat )
    ! Arguments
    REAL(fp),               INTENT(IN)  :: Pressure(:)
    REAL(fp),               INTENT(IN)  :: Temperature(:)
    REAL(fp),               INTENT(IN)  :: Water_Vapor_Pressure(:)
    REAL(fp),               INTENT(OUT) :: Height(:)
    REAL(fp),     OPTIONAL, INTENT(IN)  :: Surface_Height
    LOGICAL,      OPTIONAL, INTENT(IN)  :: Gravity_Correction
    REAL(fp),     OPTIONAL, INTENT(IN)  :: Latitude
    REAL(fp),     OPTIONAL, INTENT(IN)  :: Zonal_Wind_Velocity(:)
    REAL(fp),     OPTIONAL, INTENT(IN)  :: Meridional_Wind_Velocity(:)
    ! Function result
    INTEGER :: err_stat
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Geopotential_Height'
    ! Local variables
    CHARACTER(ML) :: msg
    LOGICAL :: Use_Gravity
    INTEGER :: n_Levels
    INTEGER :: k, k1, k2, dk
    REAL(fp), DIMENSION(SIZE(Pressure)) :: u, v
    REAL(fp) :: Surface_Z
    REAL(fp) :: MWair
    REAL(fp) :: Rair,   Rair_km1
    REAL(fp) :: RHOair, RHOair_km1
    REAL(fp) :: layer_Rair
    REAL(fp) :: layer_T
    REAL(fp) :: g
    REAL(fp) :: H
    REAL(fp) :: dz

    ! Setup
    err_stat = SUCCESS

    ! Check mandatory inputs
    ! ...Check input array sizes
    n_Levels = SIZE(Pressure)
    IF ( SIZE(Temperature)          /= n_Levels .OR. &
         SIZE(Water_Vapor_Pressure) /= n_Levels ) THEN
      err_stat = FAILURE
      msg = 'Inconsistent input array sizes.'
      CALL Display_Message( ROUTINE_NAME, msg, err_stat ); RETURN
    ENDIF
    ! ...Check output array size
    IF ( SIZE(Height) < n_Levels  ) THEN
      err_stat = FAILURE
      msg = 'Output HEIGHT array too small to hold result.'
      CALL Display_Message( ROUTINE_NAME, msg, err_stat ); RETURN
    ENDIF
    ! ...Check input array values
    IF ( ANY(Pressure < TOLERANCE) ) THEN
      err_stat = FAILURE
      msg = 'Input pressures < or = 0 found.'
      CALL Display_Message( ROUTINE_NAME, msg, err_stat ); RETURN
    ENDIF
    IF ( ANY(Temperature < TOLERANCE )) THEN
      err_stat = FAILURE
      msg = 'Input temperatures < or = 0 found.'
      CALL Display_Message( ROUTINE_NAME, msg, err_stat ); RETURN
    ENDIF
    IF ( ANY(Water_Vapor_Pressure < ZERO )) THEN
      err_stat = FAILURE
      msg = 'Input water vapour partial pressures < 0 found.'
      CALL Display_Message( ROUTINE_NAME, msg, err_stat ); RETURN
    ENDIF

    ! Default surface height is 0.0....
    Surface_Z = ZERO
    ! ...unless the surface height argument is present
    IF ( PRESENT( Surface_Height ) ) THEN
      Surface_Z = Surface_Height
    ELSE
      Surface_Z = ZERO
    END IF

    ! Default is NOT to calculate a gravity profile....
    Use_Gravity = .FALSE.
    ! ...unless the gravity correction argument is set.
    IF ( PRESENT(Gravity_Correction) ) THEN
      Use_Gravity = Gravity_Correction
      IF ( Use_Gravity ) THEN
        ! Check zonal wind velocity
        u = ZERO
        IF ( PRESENT(Zonal_Wind_Velocity) ) THEN
          IF ( SIZE(Zonal_Wind_Velocity) /= n_Levels ) THEN
            err_stat = FAILURE
            msg = 'Input ZONAL_WIND_VELOCITY has inconsistent array size.'
            CALL Display_Message( ROUTINE_NAME, msg, err_stat ); RETURN
          ELSE
            u = Zonal_Wind_Velocity
          END IF
        END IF
        ! Check meridional wind velocity
        v = ZERO
        IF ( PRESENT(Meridional_Wind_Velocity) ) THEN
          IF ( SIZE(Meridional_Wind_Velocity) /= n_Levels ) THEN
            err_stat = FAILURE
            msg = 'Input MERIDIONAL_WIND_VELOCITY has inconsistent array size.'
            CALL Display_Message( ROUTINE_NAME, msg, err_stat ); RETURN
          ELSE
            v = Meridional_Wind_Velocity
          END IF
        END IF
      END IF
    END IF

    ! Determine order of input pressure
    IF ( Pressure(2) < Pressure (1) ) THEN
      ! ...Ascending, i.e. ground up
      k1 = 1
      k2 = n_Levels
      dk = 1
    ELSE
      ! ...Descending, i.e. TOA down
      k1 = n_Levels
      k2 = 1
      dk = -1
    END IF

    ! Calculate near surface level values
    ! ...Molecular weight of air
    CALL MW_Air( Pressure(k1), Water_Vapor_Pressure(k1), MWair )
    ! ...Calculate the gas "constant" in J/K/kg
    Rair_km1 = R0 / ( MWair * G_TO_KG )
    ! Air density
    CALL Density( Pressure(k1), Temperature(k1), MWair, RHOair_km1 )

    ! Loop over levels in ground-up order
    ! ...Assign first level height
    Height(k1) = Surface_Z
    ! ...Begin level loop
    Level_Loop: DO k = k1+dk, k2, dk

      ! Calculate current level values
      ! ...MWair at current level
      CALL MW_Air( Pressure(k), Water_Vapor_Pressure(k), MWair )
      ! ...Gas "constant" at current level in J/K/kg
      Rair = R0 / ( MWair * G_TO_KG )
      ! ...Air density at current level
      CALL Density( Pressure(k), Temperature(k), MWair, RHOair )

      ! Calculate density weighted layer averages
      ! ...Gas "constant"
      layer_Rair = ( ( Rair_km1*RHOair_km1 ) + ( Rair*RHOair ) ) / ( RHOair_km1+RHOair )
      ! ...Temperature
      layer_T = ( ( Temperature(k-dk)*RHOair_km1 ) + ( Temperature(k)*RHOair ) ) / ( RHOair_km1+RHOair )

      ! Calculate gravity value if required
      IF ( Use_Gravity ) THEN
        ! ...Calculate gravity at layer lower boundary
        g = Gravity( Height(k-dk), &
                     Latitude                 = Latitude, &
                     Zonal_Wind_Velocity      = u(k-dk), &
                     Meridional_Wind_Velocity = v(k-dk) )
        IF ( g < ZERO ) THEN
          err_stat = FAILURE
          msg = 'Gravity calculation failed.'
          CALL Display_Message( ROUTINE_NAME, msg, err_stat ); RETURN
        END IF
      ELSE
        ! ...Use standard gravity
        g = G0
      END IF

      ! Calculate scale height. Here, if a gravity profile
      ! is used, we assume that the gravity at the lower
      ! layer boundary is a good approximation for that
      ! in the middle of the layer.
      H = layer_Rair * layer_T / g

      ! Calculate layer thickness
      dz = H * LOG(Pressure(k-dk) / Pressure(k))

      ! Accumulate heights
      Height(k) = Height(k-dk) + dz

      ! Save current level Rair and RHOair
      Rair_km1   = Rair
      RHOair_km1 = RHOair

    END DO Level_Loop

  END FUNCTION Geopotential_Height

!################################################################################
!################################################################################
!##                                                                            ##
!##                        ## PRIVATE MODULE ROUTINES ##                       ##
!##                                                                            ##
!################################################################################
!################################################################################

!--------------------------------------------------------------------------------
!
! NAME:
!       Gravity
!
! PURPOSE:
!       Function to calculate gravity as a function of height, latitude, and,
!       if supplied, zonal and meridional wind velocity.
!
!       Adapted and updated from the UMBC GRAV.F function supplied with the
!       AIRS RTA.
!
! CALLING SEQUENCE:
!       g = Gravity( Height                                             , &
!                    Latitude                 = Latitude                , &
!                    Zonal_Wind_Velocity      = Zonal_Wind_Velocity     , &
!                    Meridional_Wind_Velocity = Meridional_Wind_Velocity  )
!
! INPUTS:
!       Height:                    Height at which the gravity value is required.
!                                  UNITS:      metres (m)
!                                  TYPE:       REAL(fp)
!                                  DIMENSION:  Scalar
!                                  ATTRIBUTES: INTENT(IN)
!
! OPTIONAL INPUTS:
!       Latitude:                  Set this argument to the latitude at which
!                                  the gravity value is required.
!                                  If not defined, the default value is 0.0.
!                                  UNITS:      Degrees
!                                  TYPE:       REAL(fp)
!                                  DIMENSION:  Scalar
!                                  ATTRIBUTES: INTENT(IN)
!
!       Zonal_Wind_Velocity:       Set this argument to the zonal wind
!                                  velocities at the input height.
!                                  If not defined, the default value is 0.0.
!                                  UNITS:      m.s^-1, +ve W'ly, -ve E'ly
!                                  TYPE:       REAL(fp)
!                                  DIMENSION:  Scalar
!                                  ATTRIBUTES: OPTIONAL, INTENT(IN)
!
!       Meridional_Wind_Velocity:  Set this argument to the meridional wind
!                                  velocities at the input height.
!                                  If not defined, the default value is 0.0.
!                                  UNITS:      m.s^-1, +ve S'ly, -ve N'ly
!                                  TYPE:       REAL(fp)
!                                  DIMENSION:  Scalar
!                                  ATTRIBUTES: OPTIONAL, INTENT(IN)
!
! FUNCTION RESULT:
!       g:                         The acceleration due to gravity.
!                                  If an error occurs, -1.0 is returned.
!                                  UNITS:      m.s^-2
!                                  TYPE:       REAL(fp)
!                                  DIMENSION:  Scalar
!
! PROCEDURE:
!       The gravity at some height, z, and latitude, lat, can be expressed as
!
!         g(z,lat) = g_surface(lat).f(lat,z) - a(lat,z)     .....(1)
!
!       where g_surface(lat) = gravity at the Earth's surface due to Earth's
!                              mass only,
!             f(lat,z)       = factor modifying surface gravity due to inverse
!                              square law,
!             a(lat,z)       = centripetal acceleration due to rotation of
!                              mass (atmosphere) at height, z
!
!
!       Normal Gravity
!       --------------
!
!       The normal Gravity is determined from the International Gravity
!       equation (Moritz, H., "Geodetic Reference System 1980", See: Geodesists
!       Handbook, Bulletin Geodesique, v62,1988),
!
!                                    __ 4
!                              (    \             2i      )
!         g_normal(lat) = g0 * ( 1 + >  c(i) . SIN  (lat) )     .....(2)
!                              (    /__                   )
!                                      i=1
!
!       where g0_normal = normal gravity at the equator,
!             c(i)      = coefficients.
!
!       Eqn.2 provides a value for gravity due both to the Earth's mass and
!       rotation, i.e. it contains a surface centripetal acceleration
!       component,
!
!         g_normal(lat) = g_surface(lat) - a_surface(lat)
!
!       therefore, one gets,
!
!         g_surface(lat) = g_normal(lat) + a_surface(lat)     .....(3)
!
!
!       Centripetal acceleration
!       ------------------------
!
!       The centripetal acceleration at the Earth's surface can be expressed
!       as,
!
!                             V(lat)^2
!         a_surface( Lat ) = ----------     .....(4)
!                              Re(lat)
!
!       where V(lat) = speed of rotation of the Earth's surface at a given
!                      latitude,
!
!         V(lat) = 2pi * w * Re(lat) * cos(lat)
!
!       where w = the angular velocity of Earth's surface in rev.s^-1
!       (1/86400 rev.s^-1) and 2pi*w is the same in rad.s^-1
!       (2pi / 86400 rad.s^-1)
!
!       and Re(lat) = Earth's radius at some latitude, lat,
!                         _________________________________________
!                        /
!                       /               2
!                      /               R (polar)
!                     / ------------------------------------------
!                    /                    (          2          )
!         Re(lat) = /            2        (        Re polar     )
!                  /      1 - cos (lat) * ( 1 - --------------- )
!                 /                       (        2            )
!                /                        (      Re equatorial  )
!              \/
!
!       Thus, eqn. (4) becomes
!
!                             ( 2pi * w * Re(lat) * cos(lat) )^2
!         a_surface( Lat ) = ------------------------------------
!                                         Re(lat)
!
!                          = ( 2pi * w * cos(lat) )^2 * Re(lat)
!
!
!       To determine the centripetal acceleration at some height z, we
!       assume that the only thing preventing the air mass at z moving
!       at a different speed than that of the rotating Earth is the wind
!       parallel to the Earth's surface. Thus the rotational speed is
!       modified by the zonal, u(z), and meridional wind, v(z), speed,
!
!                     V(lat,z)^2
!         a(lat,z) = ------------     .....(5)
!                      R(lat,z)
!
!       where,
!                       _______________________________________________________
!                      /
!         V(lat,z) =  / [ ( 2pi * w * R(lat,z) * cos(lat) ) + u(z) ]^2 + v(z)^2
!                   \/
!
!       and,
!
!         R(lat,z) = Re(lat) + Z
!
!       So, like before, (5) becomes,
!
!                   [ ( 2pi * w * R(lat,z) * cos(lat) ) + u(z) ]^2 + v(z)^2
!       a(lat,z) = ---------------------------------------------------------
!                                          R(lat,z)
!
!
!       Variation of gravity with altitude
!       ----------------------------------
!
!       From eqn.1, the variation of gravitation due only to height above
!       the surface can be expressed as,
!
!          g_surface(lat).f(lat,z)
!
!       where, using the inverse square law,
!
!                                  2
!                    (  Re(lat)   )
!         f(lat,z) = ( ---------- )     .....(6)
!                    (  R(lat,z)  )
!
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 17-Jan-2001
!                       paul.vandelst@noaa.gov
!
!--------------------------------------------------------------------------------

  FUNCTION Gravity( &
    Height                  , &  ! Input
    Latitude                , &  ! Optional input
    Zonal_Wind_Velocity     , &  ! Optional input
    Meridional_Wind_Velocity  )  ! Optional input
    ! Arguments
    REAL(fp),           INTENT(IN) :: Height
    REAL(fp), OPTIONAL, INTENT(IN) :: Latitude
    REAL(fp), OPTIONAL, INTENT(IN) :: Zonal_Wind_Velocity
    REAL(fp), OPTIONAL, INTENT(IN) :: Meridional_Wind_Velocity

    ! Function result
    REAL(fp) :: Gravity

    ! Local parameters
    CHARACTER(*),  PARAMETER :: ROUTINE_NAME = 'Gravity'
    REAL(fp), PARAMETER :: TWO_PI = TWO * PI
    REAL(fp), PARAMETER :: DEGREES_TO_RADIANS = PI / 180.0_fp
    ! ...Earth rotational speed in rad.s^-1. The number of seconds
    !    per day is for a sidereal day, the amount of time for the
    !    Earth to rotate 360 degrees: 23h, 56m, 4s. A solar day is
    !    24h long. It makes next to no difference in the calculated
    !    gravity, but what the hell.
    REAL(fp), PARAMETER :: N_SECONDS_IN_DAY = 86164.0_fp
    REAL(fp), PARAMETER :: OMEGA = TWO_PI / N_SECONDS_IN_DAY
    ! ...Earth radii in m.
    REAL(fp), PARAMETER :: Re_Equatorial = 6.378388e+06_fp ! == a
    REAL(fp), PARAMETER :: Re_Polar      = 6.356911e+06_fp ! == b
    ! ...Earth's flattening correction factor, (1 - b^2/a^2)
    REAL(fp), PARAMETER :: a2      = Re_Equatorial**2
    REAL(fp), PARAMETER :: b2      = Re_Polar**2
    REAL(fp), PARAMETER :: factor  = ONE - ( b2 / a2 )
    ! ...Data for normal gravity equation
    REAL(fp), PARAMETER :: G_NORMAL_EQUATOR      = 9.7803267715_fp
    INTEGER,  PARAMETER :: N_NORMAL_COEFFICIENTS = 4
    REAL(fp), PARAMETER :: G_COEFFS(N_NORMAL_COEFFICIENTS) = (/ 5.2790414e-03_fp, &
                                                                2.32718e-05_fp,   &
                                                                1.262e-07_fp,     &
                                                                7.0e-10_fp        /)
    ! ...This is the number of the above coefficients to use
    !    in the calculation. Don't really need all four.
    INTEGER, PARAMETER :: N_COEFFICIENTS = 2

    ! Local variables
    CHARACTER(ML) :: msg
    INTEGER :: i
    REAL(fp) :: Lat
    REAL(fp) :: u, v
    REAL(fp) :: cos_Lat, sin_Lat
    REAL(fp) :: Re, Rtotal
    REAL(fp) :: Sum_Coeffs, g_Normal
    REAL(fp) :: a_Surface
    REAL(fp) :: a_Z
    REAL(fp) :: g_Surface

    ! Setup
    IF ( PRESENT(Latitude) ) THEN
      Lat = ABS(Latitude)
    ELSE
      Lat = ZERO
    END IF
    IF ( PRESENT(Zonal_Wind_Velocity) ) THEN
      u = Zonal_Wind_Velocity
    ELSE
      u = ZERO
    END IF
    IF ( PRESENT(Meridional_Wind_Velocity) ) THEN
      v = Meridional_Wind_Velocity
    ELSE
      v = ZERO
    END IF

    ! Calculate trigonometric terms
    !
    ! It's most likely faster to calculate the cosine squared terms here and
    ! modify the equations down the line to use the precalculated value rather
    ! than do cos**2 each time, but as it is now, this only occurs in two
    ! places (the calc for Re and a_Surface, and a_Z if the wind arguments
    ! aren't present) and the code reflects the equations as one would write
    ! them down, which makes me feel all warm and fuzzy on the inside. :o)
    cos_Lat = COS(DEGREES_TO_RADIANS * Lat)
    sin_Lat = SIN(DEGREES_TO_RADIANS * Lat)

    ! Calculate radius terms
    ! ...Calculate the Earth's radius at this Latitude
    Re = SQRT(b2 / ( ONE - ( cos_Lat**2 * factor ) ))
    ! ...Calculate total distance from Earth's center
    Rtotal = Re + Height
    IF ( Rtotal < TOLERANCE ) THEN
      Gravity = -ONE
      msg = 'Invalid Height (<Re) input argument'
      CALL Display_Message( ROUTINE_NAME, msg, FAILURE ); RETURN
    END IF

    ! Calculate gravity at Earth's surface
    !
    ! This uses the normal Gravity equation. This equation provides Gravity
    ! due to the mass *AND* rotation of the Earth. Note that I don't use
    ! Horner's rule here. It adds an extra iteration and the tests I performed
    ! showed no difference form the simple method below.
    Sum_Coeffs = ZERO
    DO i = 1, N_COEFFICIENTS
      Sum_Coeffs = Sum_Coeffs + ( G_COEFFS( i ) * sin_Lat**( 2*i ) )
    END DO
    g_Normal = G_NORMAL_EQUATOR * ( ONE + Sum_Coeffs )

    ! Calculate centripetal acceleration at Earth's surface
    a_Surface = ( OMEGA * cos_Lat )**2 * Re

    ! Calculate centripetal accelleration at height Z
    IF ( PRESENT(Zonal_Wind_Velocity) .OR. PRESENT(Meridional_Wind_Velocity) ) THEN
      a_Z = ( ( ( OMEGA * Rtotal * cos_Lat ) + u )**2 + v**2 ) / Rtotal
    ELSE
      a_Z = ( OMEGA * cos_Lat )**2 * Rtotal
    END IF

    ! Calcaulte the gravity at the Earth's surface,
    ! *REMOVING* the effect of the Earth's rotation
    g_Surface = g_Normal + a_Surface

    ! Calculate the gravitational acceleration at height Z
    ! incorporating the centripetal acceleration at height Z
    Gravity = g_Surface * ( Re/Rtotal )**2 - a_Z

  END FUNCTION Gravity

END MODULE Geopotential