      program test
      real*4  spherdist,elipsdist
      real    lon1,lat1,lon2,lat2,sd,ed
      integer i
c
      write(6,*) '1-degree in longitude at equator'
      do i= -180,180,5
        lon1 = i-0.5
        lon2 = i+0.5
        lat1 = 0.0d0
        lat2 = 0.0d0
        sd   = spherdist(lon1,lat1,lon2,lat2)
        ed   = elipsdist(lon1,lat1,lon2,lat2)
        write(6,'(2f12.2,i6)') ed,sd,i
      enddo
      write(6,*)
      write(6,*) '1-degree in latitude at 0E'
      do i= -89,-86
        lon1 = 0.0d0
        lon2 = 0.0d0
        lat1 = i-0.5
        lat2 = i+0.5
        sd   = spherdist(lon1,lat1,lon2,lat2)
        ed   = elipsdist(lon1,lat1,lon2,lat2)
        write(6,'(2f12.2,i6)') ed,sd,i
      enddo
      do i= -85,85,5
        lon1 = 0.0d0
        lon2 = 0.0d0
        lat1 = i-0.5
        lat2 = i+0.5
        sd   = spherdist(lon1,lat1,lon2,lat2)
        ed   = elipsdist(lon1,lat1,lon2,lat2)
        write(6,'(2f12.2,i6)') ed,sd,i
      enddo
      do i= 86,89
        lon1 = 0.0d0
        lon2 = 0.0d0
        lat1 = i-0.5
        lat2 = i+0.5
        sd   = spherdist(lon1,lat1,lon2,lat2)
        ed   = elipsdist(lon1,lat1,lon2,lat2)
        write(6,'(2f12.2,i6)') ed,sd,i
      enddo
      end
      real*4 function spherdist(lon1,lat1,lon2,lat2)
      implicit none
      real, intent(in) :: lon1,lat1,lon2,lat2 ! Pos. in degrees
c
c --- -------------------------------------------
c --- Computes the distance between geo. pos.
c --- lon1,lat1 and lon2,lat2.
c --- INPUT is in degrees.
c
c --- Based on m_spherdist.F90 from Geir Evanson.
c --- -------------------------------------------
c
      double precision, parameter :: invradian=0.017453292d0
      double precision, parameter ::    rearth=6371001.0d0  ! Radius of earth
c
      double precision  rlon1,rlat1,rlon2,rlat2           ! Pos. in radians
      double precision  x1,y1,z1,x2,y2,z2                 ! Cartesian position
      double precision  dx,dy,dz,dr                       ! Cartesian distances
c
      rlon1=lon1*invradian             !lon1 in rad
      rlat1=(90.d0-lat1)*invradian     !90-lat1 in rad
c
      rlon2=lon2*invradian             !lon2 in rad
      rlat2=(90.d0-lat2)*invradian     !90-lat2 in rad
c
      x1= sin(rlat1)*cos(rlon1)        !x,y,z of pos 1.
      y1= sin(rlat1)*sin(rlon1)
      z1= cos(rlat1)
c
      x2= sin(rlat2)*cos(rlon2)        !x,y,z of pos 2.
      y2= sin(rlat2)*sin(rlon2)
      z2= cos(rlat2)
c
      dr=acos(x1*x2+y1*y2+z1*z2)       ! Arc length
c
      spherdist=dr*rearth
c
      end function spherdist

      real*4 function elipsdist(lon1,lat1,lon2,lat2)
      implicit none
      real, intent(in) :: lon1,lat1,lon2,lat2 ! Pos. in degrees
c
c --- ------------------------------------------------
c --- Computes the distance between geo. pos.
c --- lon1,lat1 and lon2,lat2.
c --- input is in degrees.
c
c --- output is real*4 for better global consistancy,
c --- by truncating double precision roundoff errors.
c --- real*4 is not in f90, but is widely supported.
c --- ------------------------------------------------
c
      double precision dlon1,dlon2
      double precision rlon1,rlat1,rlon2,rlat2    ! Pos. in radians
      double precision edist                      ! distance (m)
      double precision baz,faz                    ! azimuth (ignored)
      double precision esq                        ! eccentricity sq.
c
      double precision pi,rad
      double precision a,f
      common/const/pi,rad
      save  /const/
      common/elipsoid/a,f
      save  /elipsoid/
c
      pi   = 4.d0*datan(1.d0)
      rad  = 180.d0/pi
c --- GRS80 / WGS84  (NAD83)
      a    = 6378137.d0
      f    = 1.d0/298.25722210088d0
c
      esq = f*(2.0d0-f)
c
c     ensure that spherdist(ax,ay,bx,by) == spherdist(bx,by,ax,ay)
c
      dlon1 = lon1
      dlon1 = mod(dlon1,360.d0)
      if     (dlon1.lt.0.d0) then
        dlon1 = dlon1 + 360.d0
      endif
      dlon2 = lon2
      dlon2 = mod(dlon2,360.d0)
      if     (dlon2.lt.0.d0) then
        dlon2 = dlon2 + 360.d0
      endif
      if     (lat1.lt.lat2) then
        rlon1=dlon1/rad
        rlat1= lat1/rad
        rlon2=dlon2/rad
        rlat2= lat2/rad
      elseif (lat1.eq.lat2 .and. dlon1.le.dlon2) then
        rlon1=dlon1/rad
        rlat1= lat1/rad
        rlon2=dlon2/rad
        rlat2= lat2/rad
      else
        rlon2=dlon1/rad
        rlat2= lat1/rad
        rlon1=dlon2/rad
        rlat1= lat2/rad
      endif
c
      call gpnhri(a,f,esq,pi,
     &            rlat1,rlon1,rlat2,rlon2,
     &            faz,baz,edist)
      elipsdist = edist
      end
C###
      subroutine gpnhri (a,f,esq,pi,p1,e1,p2,e2,az1,az2,s)
c
c********1*********2*********3*********4*********5*********6*********7*
c
c name:        gpnhri
c version:     200208.09
c written by:  robert (sid) safford
c purpose:     subroutine to compute helmert rainsford inverse problem
c
c     solution of the geodetic inverse problem after t. vincenty
c     modified rainsford's method with helmert's elliptical terms
c     effective in any azimuth and at any distance short of antipocal
c     from/to stations must not be the geographic pole.
c     parameter a is the semi-major axis of the reference ellipsoid
c     finv=1/f is the inverse flattening of the reference ellipsoid
c     latitudes and longitudes in radians positive north and west
c     forward and back azimuths returned in radians clockwise from south
c     geodesic distance s returned in units of semi-major axis a
c     programmed for ibm 360-195   09/23/75
c
c     note - note - note -
c     1. do not use for meridional arcs and be careful on the equator.
c     2. azimuths are from north(+) clockwise and
c     3. longitudes are positive east(+)
c
c input parameters:
c -----------------
c a            semi-major axis of reference ellipsoid      meters
c f            flattening (0.0033528...)
c esq          eccentricity squared
c pi           3.14159...
c p1           lat station 1                               radians
c e1           lon station 1                               radians
c p2           lat station 2                               radians
c e2           lon station 2                               radians
c
c output parameters:
c ------------------
c az1          azi at sta 1 -> sta 2                       radians
c az2          azi at sta 2 -> sta 1                       radians
c s            geodetic dist between sta(s) 1 & 2          meters
c
c local variables and constants:
c ------------------------------
c aa               constant from subroutine gpnloa
c alimit           equatorial arc distance along the equator   (radians)
c arc              meridional arc distance latitude p1 to p2 (in meters)
c az1              azimuth forward                          (in radians)
c az2              azimuth back                             (in radians)
c bb               constant from subroutine gpnloa
c dlon             temporary value for difference in longitude (radians)
c equ              equatorial distance                       (in meters)
c r1,r2            temporary variables
c s                ellipsoid distance                        (in meters)
c sms              equatorial - geodesic distance (S - s) "Sms"
c ss               temporary variable
c tol0             tolerance for checking computation value
c tol1             tolerance for checking a real zero value
c tol2             tolerance for close to zero value
c twopi            two times constant pi
c
c global variables and constants:
c -------------------------------
c
c    module called by:    general
c
c    this module calls:   gpnarc, gpnloa
c       llibfore/ dsin,   dcos,   dsqrt,  dabs,  datan2, write
c
c    include files used:
c    common blocks used:
c
c    references: microsoft fortran 4.10 optimizing compiler, 1988
c                ms-dos operating system
c    comments:
c********1*********2*********3*********4*********5*********6*********7*
c::modification history
c::197507.05, rws, ver 00 tencol released for field use
c::198311.20, rws, ver 01 mten   released to field
c::198411.26, rws, ver 07 mten2  released to field
c::198506.10, rws, wrk    enhancements released to field
c::198507.22, rws, code   modified for mten3
c::198509.01, rws, ver 11 mten3  released to field
c::198708.10, rws, code   modified to use new mten4 gpn record format
c::199112.31, rws, ver 20 mten4 released to field
c::200001.13, rws, ver 21 mten4 released to field
c::200005.26, rws, code   restructured & documentation added
c::200012.31, rws, ver 23 mten5 released
c::200104.09, rws, code   added to calblin program
c::200208.09, rws, code   added subroutines gpnarc & gpnloa
c********1*********2*********3*********4*********5*********6*********7*
ce::gpnhri
c  -------------------------------
c     m t e n  (version 3)
c              (version 4.22)
c              (version 5.23)
c  -------------------------------
c
      implicit real*8 (a-h,o-z)
c
      data tol0 /5.0d-15/
      data tol1 /5.0d-14/
      data tol2 /7.0d-03/
c
      twopi = 2.0d0*pi
c
c     test the longitude difference with tol1
c     tol1 is approximately 0.000000001 arc seconds
c
      ss = e2-e1
      if( dabs(ss).lt.tol1 )then
        e2 = e2+tol1
*       write(*,*) ' longitudal difference is near zero '
c
        r2 = p2
        r1 = p1
        call gpnarc ( a, f, esq, pi, r1, r2, arc )
        s  = dabs( arc )
c
        if( p2.gt.p1 )then
          az1 = 0.0d0
          az2 = pi
        else
          az1 = pi
          az2 = 0.0d0
        endif
        return
      endif
c
c     test for longitude over 180 degrees
c
      dlon = e2-e1
c
      if( dlon.ge.0.0d0 )then
        if( pi.le.dlon .and. dlon.lt.twopi )then
          dlon = dlon-twopi
        endif
      else
        ss = dabs(dlon)
        if( pi.le.ss .and. ss.lt.twopi )then
          dlon = dlon+twopi
        endif
      endif
c
      ss = dabs( dlon )
      if( ss.gt.pi )then
c::     write(*,*) '  '
c::     write(*,*) ' Longitude difference over 180 degrees  '
c::     write(*,*) ' Turn it around '
        ss = twopi-ss
      endif
c
c     compute the limit in longitude (alimit), it is equal
c     to twice the distance from the equator to the pole,
c     as measured along the equator (east/ewst)
c
      alimit = pi*(1.0d0-f)
c
c     test for anti-nodal difference
c
      if( ss.ge.alimit )then
        r1 = dabs(p1)
        r2 = dabs(p2)
c
c       latitudes r1 & r2 are not near the equator
c
        if( r1.gt.tol2 .and. r2.gt.tol2 )then
          goto 60
        endif
c
c       longitude difference is greater than lift-off point
c       now check to see if  "both"  r1 & r2 are on equator
c
        if( r1.lt.tol1 .and. r2.gt.tol2 )then
          goto 60
        endif
        if( r2.lt.tol1 .and. r1.gt.tol2 )then
          goto 60
        endif
c
c       check for either r1 or r2 just off the equator but < tol2
c
        if( r1.gt.tol1. or. r2.gt.tol1 )then
          az1 = 0.0d0
          az2 = 0.0d0
          s   = 0.0d0
          return
        endif
c
c       compute the azimuth to anti-nodal point
c
c::     write(*,*) '  '
c::     write(*,*) ' Longitude difference beyond lift-off point '
c::     write(*,*) '  '
c
        call gpnloa (a,f,esq,pi,dlon,az1,az2,aa,bb,sms)
c
c       compute the equatorial distance & geodetic
c
        equ = a*dabs(dlon)
        s   = equ-sms
        return
      endif
c
   60 continue
c
      f0   = (1.0d0-f)
      b    = a*f0
      epsq = esq/(1.0d0-esq)
      f2   = f*f
      f3   = f*f2
      f4   = f*f3
c
c     the longitude difference
c
      dlon  = e2-e1
      ab    = dlon
      kount = 0
c
c     the reduced latitudes
c
      u1    = f0*dsin(p1)/dcos(p1)
      u2    = f0*dsin(p2)/dcos(p2)
c
      u1    = datan(u1)
      u2    = datan(u2)
c
      su1   = dsin(u1)
      cu1   = dcos(u1)
c
      su2   = dsin(u2)
      cu2   = dcos(u2)
c
c     counter for the iteration operation
c
    1 kount = kount+1
c
      clon  = dcos(ab)
      slon  = dsin(ab)
c
      csig  = su1*su2+cu1*cu2*clon
      ssig  = dsqrt((slon*cu2)**2+(su2*cu1-su1*cu2*clon)**2)
c
      sig   = datan2(ssig,csig)
      sinalf=cu1*cu2*slon/ssig
c
      w   = (1.0d0-sinalf*sinalf)
      t4  = w*w
      t6  = w*t4
c
c     the coefficients of type a
c
      ao  = f-f2*(1.0d0+f+f2)*w/4.0d0+3.0d0*f3*(1.0d0+
     1        9.0d0*f/4.0d0)*t4/16.0d0-25.0d0*f4*t6/128.0d0
      a2  = f2*(1.0d0+f+f2)*w/4.0d0-f3*(1.0d0+9.0d0*f/4.0d0)*t4/4.0d0+
     1        75.0d0*f4*t6/256.0d0
      a4  = f3*(1.0d0+9.0d0*f/4.0d0)*t4/32.0d0-15.0d0*f4*t6/256.0d0
      a6  = 5.0d0*f4*t6/768.0d0
c
c     the multiple angle functions
c
      qo  = 0.0d0
      if( w.gt.tol0 )then
        qo = -2.0d0*su1*su2/w
      endif
c
      q2  = csig+qo
      q4  = 2.0d0*q2*q2-1.0d0
      q6  = q2*(4.0d0*q2*q2-3.0d0)
      r2  = 2.0d0*ssig*csig
      r3  = ssig*(3.0d0-4.0d0*ssig*ssig)
c
c     the longitude difference
c
      s   = sinalf*(ao*sig+a2*ssig*q2+a4*r2*q4+a6*r3*q6)
      xz  = dlon+s
c
      xy  = dabs(xz-ab)
      ab  = dlon+s
c
      if( xy.lt.0.5d-13 )then
        goto 4
      endif
c
      if( kount.le.7 )then
        goto 1
      endif
c
c     the coefficients of type b
c
    4 z   = epsq*w
c
      bo  = 1.0d0+z*(1.0d0/4.0d0+z*(-3.0d0/64.0d0+z*(5.0d0/256.0d0-
     1         z*175.0d0/16384.0d0)))
      b2  = z*(-1.0d0/4.0d0+z*(1.0d0/16.0d0+z*(-15.0d0/512.0d0+
     1         z*35.0d0/2048.0d0)))
      b4  = z*z*(-1.0d0/128.0d0+z*(3.0d0/512.0d0-z*35.0d0/8192.0d0))
      b6  = z*z*z*(-1.0d0/1536.0d0+z*5.0d0/6144.0d0)
c
c     the distance in meters
c
      s   = b*(bo*sig+b2*ssig*q2+b4*r2*q4+b6*r3*q6)
c
c     first compute the az1 & az2 for along the equator
c
      if( dlon.gt.pi )then
        dlon = (dlon-2.0d0*pi)
      endif
c
      if( dabs(dlon).gt.pi )then
        dlon = (dlon+2.0d0*pi)
      endif
c
      az1 = pi/2.0d0
      if( dlon.lt.0.0d0 )then
        az1 = 3.0d0*az1
      endif
c
      az2 = az1+pi
      if( az2.gt.2.0d0*pi )then
        az2 = az2-2.0d0*pi
      endif
c
c     now compute the az1 & az2 for latitudes not on the equator
c
      if( .not.(dabs(su1).lt.tol0 .and. dabs(su2).lt.tol0) )then
        tana1 =  slon*cu2/(su2*cu1-clon*su1*cu2)
        tana2 =  slon*cu1/(su1*cu2-clon*su2*cu1)
        sina1 =  sinalf/cu1
        sina2 = -sinalf/cu2
c
c       azimuths from north,longitudes positive east
c
        az1   = datan2(sina1,sina1/tana1)
        az2   = pi-datan2(sina2,sina2/tana2)
      endif
c
      if( az1.lt.0.0d0 )then
        az1 = az1+2.0d0*pi
      endif
c
      if( az2.lt.0.0d0 )then
        az2 = az2+2.0d0*pi
      endif
c
      return
      end

CB::GPNLOA
C
      SUBROUTINE GPNARC (AMAX,FLAT,ESQ,PI,P1,P2,ARC)
C
C********1*********2*********3*********4*********5*********6*********7*
C
C NAME:        GPNARC
C VERSION:     200005.26
C WRITTEN BY:  ROBERT (Sid) SAFFORD
C PURPOSE:     SUBROUTINE TO COMPUTE THE LENGTH OF A MERIDIONAL ARC
C              BETWEEN TWO LATITUDES
C
C INPUT PARAMETERS:
C -----------------
C AMAX         SEMI-MAJOR AXIS OF REFERENCE ELLIPSOID
C FLAT         FLATTENING (0.0033528 ... )
C ESQ          ECCENTRICITY SQUARED FOR REFERENCE ELLIPSOID
C PI           3.14159...
C P1           LAT STATION 1
C P2           LAT STATION 2
C
C OUTPUT PARAMETERS:
C ------------------
C ARC          GEODETIC DISTANCE
C
C LOCAL VARIABLES AND CONSTANTS:
C ------------------------------
C GLOBAL VARIABLES AND CONSTANTS:
C -------------------------------
C
C    MODULE CALLED BY:    GENERAL
C
C    THIS MODULE CALLS:
C       LLIBFORE/ OPEN,   CLOSE,  READ,   WRITE,  INQUIRE
C                 DABS,   DBLE,   FLOAT,  IABS,   CHAR,   ICHAR
C
C    INCLUDE FILES USED:
C    COMMON BLOCKS USED:
C
C    REFERENCES: Microsoft FORTRAN 4.10 Optimizing Compiler, 1988
C                MS-DOS Operating System
C    COMMENTS:
C********1*********2*********3*********4*********5*********6*********7*
C::MODIFICATION HISTORY
C::197507.05, RWS, VER 00 TENCOL RELEASED FOR FIELD USE
C::198311.20, RWS, VER 01 MTEN   RELEASED TO FIELD
C::198411.26, RWS, VER 07 MTEN2  RELEASED TO FIELD
C::1985xx.xx, RWS, CODE   CREATED
C::198506.10, RWS, WRK    ENHANCEMENTS RELEASED TO FIELD
C::198509.01, RWS, VER 11 MTEN3  RELEASED TO FIELD
C::198512.18, RWS, CODE   MODIFIED FOR MTEN3
C::198708.10, RWS, CODE   MODIFIED TO USE NEW MTEN4 GPN RECORD FORMAT
C::199112.31, RWS, VER 20 MTEN4 RELEASED TO FIELD
C::200001.13, RWS, VER 21 MTEN4 RELEASED TO FIELD
C::200005.26, RWS, CODE   RESTRUCTURED & DOCUMENTATION ADDED
C::200012.31, RWS, VER 23 MTEN5 RELEASED
C********1*********2*********3*********4*********5*********6*********7*
CE::GPNARC
C ---------------------------
C     M T E N  (VERSION 3)
C     M T E N  (VERSION 5.23)
C ---------------------------
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      LOGICAL  FLAG
C
      DATA TT/5.0D-15/
C
C     CHECK FOR A 90 DEGREE LOOKUP
C
      FLAG = .FALSE.
C
      S1 = DABS(P1)
      S2 = DABS(P2)
C
      IF( (PI/2.0D0-TT).LT.S2 .AND. S2.LT.(PI/2.0D0+TT) )THEN
        FLAG = .TRUE.
      ENDIF
C
      IF( S1.GT.TT )THEN
        FLAG = .FALSE.
      ENDIF
C
      DA = (P2-P1)
      S1 = 0.0D0
      S2 = 0.0D0
C
C     COMPUTE THE LENGTH OF A MERIDIONAL ARC BETWEEN TWO LATITUDES
C
      E2 = ESQ
      E4 = E2*E2
      E6 = E4*E2
      E8 = E6*E2
      EX = E8*E2
C
      T1 = E2*(003.0D0/4.0D0)
      T2 = E4*(015.0D0/64.0D0)
      T3 = E6*(035.0D0/512.0D0)
      T4 = E8*(315.0D0/16384.0D0)
      T5 = EX*(693.0D0/131072.0D0)
C
      A  = 1.0D0+T1+3.0D0*T2+10.0D0*T3+35.0D0*T4+126.0D0*T5
C
      IF( FLAG )THEN
        GOTO 1
      ENDIF
C
      B  = T1+4.0D0*T2+15.0D0*T3+56.0D0*T4+210.0D0*T5
      C  = T2+06.0D0*T3+28.0D0*T4+120.0D0*T5
      D  = T3+08.0D0*T4+045.0D0*T5
      E  = T4+010.0D0*T5
      F  = T5
C
      DB = DSIN(P2*2.0D0)-DSIN(P1*2.0D0)
      DC = DSIN(P2*4.0D0)-DSIN(P1*4.0D0)
      DD = DSIN(P2*6.0D0)-DSIN(P1*6.0D0)
      DE = DSIN(P2*8.0D0)-DSIN(P1*8.0D0)
      DF = DSIN(P2*10.0D0)-DSIN(P1*10.0D0)
C
C     COMPUTE THE S2 PART OF THE SERIES EXPANSION
C
      S2 = -DB*B/2.0D0+DC*C/4.0D0-DD*D/6.0D0+DE*E/8.0D0-DF*F/10.0D0
C
C     COMPUTE THE S1 PART OF THE SERIES EXPANSION
C
    1 S1 = DA*A
C
C     COMPUTE THE ARC LENGTH
C
      ARC = AMAX*(1.0D0-ESQ)*(S1+S2)
C
      RETURN
      END
      SUBROUTINE GPNLOA (AMAX,FLAT,ESQ,PI,DL,AZ1,AZ2,AO,BO,SMS)
C
C********1*********2*********3*********4*********5*********6*********7*
C
C NAME:        GPNLOA
C VERSION:     200005.26
C WRITTEN BY:  ROBERT (Sid) SAFFORD
C PURPOSE:     SUBROUTINE TO COMPUTE THE LIFF-OFF-AZIMUTH CONSTANTS
C
C INPUT PARAMETERS:
C -----------------
C AMAX         SEMI-MAJOR AXIS OF REFERENCE ELLIPSOID
C FLAT         FLATTENING (0.0033528 ... )
C ESQ          ECCENTRICITY SQUARED FOR REFERENCE ELLIPSOID
C PI           3.14159...
C DL           LON DIFFERENCE
C AZ1          AZI AT STA 1 -> STA 2
C
C OUTPUT PARAMETERS:
C ------------------
C AZ2          AZ2 AT STA 2 -> STA 1
C AO           CONST
C BO           CONST
C SMS          DISTANCE ... EQUATORIAL - GEODESIC  (S - s)   "SMS"
C
C LOCAL VARIABLES AND CONSTANTS:
C ------------------------------
C GLOBAL VARIABLES AND CONSTANTS:
C -------------------------------
C
C    MODULE CALLED BY:    GENERAL
C
C    THIS MODULE CALLS:
C       LLIBFORE/ DSIN,   DCOS,   DABS,   DASIN
C
C    INCLUDE FILES USED:
C    COMMON BLOCKS USED:
C
C    REFERENCES: Microsoft FORTRAN 4.10 Optimizing Compiler, 1988
C                MS-DOS Operating System
C    COMMENTS:
C********1*********2*********3*********4*********5*********6*********7*
C::MODIFICATION HISTORY
C::1985xx.xx, RWS, CODE   CREATED
C::198506.10, RWS, WRK    ENHANCEMENTS RELEASED TO FIELD
C::198509.01, RWS, VER 11 MTEN3  RELEASED TO FIELD
C::198512.18, RWS, CODE   MODIFIED FOR MTEN3
C::198708.10, RWS, CODE   MODIFIED TO USE NEW MTEN4 GPN RECORD FORMAT
C::199112.31, RWS, VER 20 MTEN4 RELEASED TO FIELD
C::200001.13, RWS, VER 21 MTEN4 RELEASED TO FIELD
C::200005.26, RWS, CODE   RESTRUCTURED & DOCUMENTATION ADDED
C::200012.31, RWS, VER 23 MTEN5 RELEASED
C********1*********2*********3*********4*********5*********6*********7*
CE::GPNLOA
C ---------------------------
C     M T E N  (VERSION 3)
C              (VERSION 4.22)
C              (VERSION 5.23)
C ---------------------------
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DATA TT/5.0D-13/
C
      DLON = DABS(DL)
      CONS = (PI-DLON)/(PI*FLAT)
      F    = FLAT
C
C     COMPUTE AN APPROXIMATE AZ
C
      AZ   = DASIN(CONS)
C
      T1   =    1.0D0
      T2   =  (-1.0D0/4.0D0)*F*(1.0D0+F+F*F)
      T4   =    3.0D0/16.0D0*F*F*(1.0D0+(9.0D0/4.0D0)*F)
      T6   = (-25.0D0/128.0D0)*F*F*F
C
      ITER = 0
    1 ITER = ITER+1
      S    = DCOS(AZ)
      C2   = S*S
C
C     COMPUTE NEW AO
C
      AO   = T1 + T2*C2 + T4*C2*C2 + T6*C2*C2*C2
      CS   = CONS/AO
      S    = DASIN(CS)
      IF( DABS(S-AZ).LT.TT )THEN
        GOTO 2
      ENDIF
C
      AZ   = S
      IF( ITER.LE.6 )THEN
        GOTO 1
      ENDIF
C
    2 AZ1  = S
      IF( DL.LT.0.0D0 )THEN
        AZ1 = 2.0D0*PI-AZ1
      ENDIF
C
      AZ2  = 2.0D0*PI-AZ1
C
C     EQUATORIAL - GEODESIC  (S - s)   "SMS"
C
      ESQP = ESQ/(1.0D0-ESQ)
      S    = DCOS(AZ1)
C
      U2   = ESQP*S*S
      U4   = U2*U2
      U6   = U4*U2
      U8   = U6*U2
C
      T1   =     1.0D0
      T2   =    (1.0D0/4.0D0)*U2
      T4   =   (-3.0D0/64.0D0)*U4
      T6   =    (5.0D0/256.0D0)*U6
      T8   = (-175.0D0/16384.0D0)*U8
C
      BO   = T1 + T2 + T4 + T6 + T8
      S    = DSIN(AZ1)
      SMS  = AMAX*PI*(1.0D0 - FLAT*DABS(S)*AO - BO*(1.0D0-FLAT))
C
      RETURN
      END


!GOOD
program log_sqrt

   x = 99.9
   y = log10(sqrt(x))

   if (y .lt. 1.0) &
           print *, 'x is less than 100'

end program log_sqrt


MODULE Kolmogorov_Smirnov
! Calculate 2-tail probabilities for the max abs deviation of the sample
! distribution function from the hypothetical.
! Includes KS1 which calculates exact single-tail probabilities.
! N = sample size
! D = max. abs. deviation

! N.B. The hypothesized distribution function MUST NOT use ANY parameters
!      estimated from the data used to form the empirical distribution.

IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(14, 60)

PRIVATE
PUBLIC  :: ks1, ks2

CONTAINS

FUNCTION KS2(n, d) RESULT( prob )

! Uses a combination of 3 different algorithms for different N & D.

INTEGER, INTENT(IN)    :: n
REAL (dp), INTENT(IN)  :: d
REAL (dp)              :: prob

IF (n <= 50) THEN
  prob = 1.0_dp - pks2(n, d)
ELSE IF (n > 500) THEN
  prob = KS2_asympt(n, d)
ELSE
  IF (d <= 1.2_dp / SQRT( DBLE(n) )) THEN
    IF (n <= 100) THEN
      prob = 1.0_dp - pks2(n, d)
    ELSE
      prob = KS2_asympt(n, d)
    END IF
  ELSE
    prob = 2. * KS1(n, d)
  END IF
END IF

RETURN
END FUNCTION KS2

! Code converted using TO_F90 by Alan Miller
! Date: 1999-12-28  Time: 18:34:23

!     ALGORITHM APPEARED IN COMM. ACM, VOL. 17, NO. 12, P. 703.

FUNCTION pks2(n, d) RESULT( prob )

INTEGER, INTENT(IN)    :: n
REAL (dp), INTENT(IN)  :: d
REAL (dp)              :: prob

! N IS THE SAMPLE SIZE USED.

! D IS THE MAXIMUM MAGNITUDE (OF THE DISCREPANCY BETWEEN THE EMPIRICAL AND
! PROPOSED DISTRIBUTIONS) IN EITHER THE POSITIVE OR NEGATIVE DIRECTION.
! PKS2 IS THE EXACT PROBABILITY OF OBTAINING A DEVIATION NO LARGER THAN D.
! THESE FORMULAS APPEAR AS (23) AND (24) IN J. DURBIN.  THE PROBABILITY THAT
! THE SAMPLE DISTRIBUTION FUNCTION LIES BETWEEN TWO PARALLEL STRAIGHT LINES.
! ANNALS OF MATHEMATICAL STATISTICS 39, 2(APRIL 1968), 398-411.

REAL (dp)               :: sum, ci, fn, fnd, ft, fu, fv, sign
INTEGER                 :: i, j, jmax, k, nd, ndd, nddp, ndp, ndt
REAL (dp), ALLOCATABLE  :: q(:), fact(:)
REAL (dp), PARAMETER    :: zero = 0.0_dp, one = 1.0_dp

IF (n == 1) GO TO 90
fn = n
fnd = fn*d
ndt = 2.*fnd
IF (ndt < 1) GO TO 100

ALLOCATE( q(n+1), fact(n+1) )
nd = fnd
ndd = MIN(2*nd,n)
ndp = nd + 1
nddp = ndd + 1
fact(1) = one
ci = one
DO  i=1,n
  fact(i+1) = fact(i)*ci
  ci = ci + one
END DO
q(1) = one
IF (ndd == 0) GO TO 50

ci = one
DO  i=1,ndd
  q(i+1) = ci**i/fact(i+1)
  ci = ci + one
END DO
IF (ndp > n) GO TO 80

fv = ndp - fnd
jmax = fv + 1
DO  i=ndp,ndd
  sum = zero
  ft = fnd
  k = i
  fu = fv
  DO  j=1,jmax
    sum = sum + ft**(j-2)/fact(j)*fu**k/ fact(k+1)
    ft = ft + one
    fu = fu - one
    k = k - 1
  END DO
  q(i+1) = q(i+1) - 2.*fnd*sum
  jmax = jmax + 1
  fv = fv + one
END DO
IF (ndd == n) GO TO 80

50 DO  i=nddp,n
  sum = zero
  SIGN = one
  ft = 2.*fnd
  DO  j=1,ndt
    ft = ft - one
    k = i - j + 1
    sum = sum + SIGN*ft**j/fact(j+1)*q(k)
    SIGN = -SIGN
  END DO
  q(i+1) = sum
END DO

80 prob = q(n+1)*fact(n+1) / fn**n
DEALLOCATE( q, fact )
RETURN

90 prob = 2.*d - one
RETURN

100 prob = zero
RETURN
END FUNCTION pks2

FUNCTION KS1(n, d) RESULT( prob )
! Calculates the single-tailed probability for the on sample KS test.

INTEGER, INTENT(IN)    :: n
REAL (dp), INTENT(IN)  :: d
REAL (dp)              :: prob

! Local variables
REAL (dp)  :: eps, lncj, lncj0, term
INTEGER    :: j, j0, jupper
REAL (dp), PARAMETER  :: one = 1.0_dp

eps = 10.0 * EPSILON(one)
jupper = n * (one - d)

! Evaluate one of the largest terms in the sum,
! and then sum up & down from term j0 until terms are negligible

j0 = MIN(jupper, n/2)
lncj0 = log_nCr(n, j0)
prob = EXP( lncj0 + (n-j0)*LOG(one - d - j0/DBLE(n)) +   &
                     (j0-1)*LOG(d + j0/DBLE(n)) )

lncj = lncj0
DO j = j0+1, jupper
  lncj = lncj + LOG(DBLE(n+1-j) / DBLE(j))
  term = EXP( lncj + (n-j)*LOG(one - d - j/DBLE(n)) +   &
                     (j-1)*LOG(d + j/DBLE(n)) )
  prob = prob + term
  IF (term < eps*prob) EXIT
END DO

lncj = lncj0
DO j = j0-1, 0, -1
  lncj = lncj + LOG(DBLE(j+1) / DBLE(n-j))
  term = EXP( lncj + (n-j)*LOG(one - d - j/DBLE(n)) +   &
                     (j-1)*LOG(d + j/DBLE(n)) )
  prob = prob + term
  IF (term < eps*prob) EXIT
END DO

prob = d * prob

RETURN
END FUNCTION KS1

FUNCTION log_nCr(n, r) RESULT(fn_val)
! Evaluate log of the number of combinations of r out of n.

INTEGER, INTENT(IN)  :: n, r
REAL (dp)            :: fn_val

! Local variables

INTEGER  :: i, j

! If MIN(r, n-r) < 10, use multiplications & divisions, otherwise
! use the gamma function.

j = MIN(r, n-r)
IF (j < 10) THEN
  fn_val = 1.0_dp
  DO i = 1, j
    fn_val = fn_val * (n+1-i) / DBLE(i)
  END DO
  fn_val = LOG(fn_val)
ELSE
  fn_val = lngamma(DBLE(n+1)) - lngamma(DBLE(r+1)) - lngamma(DBLE(n+1-r))
END IF

RETURN
END FUNCTION log_nCr

FUNCTION lngamma(z) RESULT(lanczos)

!  Uses Lanczos-type approximation to ln(gamma) for z > 0.
!  Reference:
!       Lanczos, C. 'A precision approximation of the gamma
!               function', J. SIAM Numer. Anal., B, 1, 86-96, 1964.
!  Accuracy: About 14 significant digits except for small regions
!            in the vicinity of 1 and 2.

!  Programmer: Alan Miller
!              1 Creswick Street, Brighton, Vic. 3187, Australia
!  Latest revision - 14 October 1996

REAL(dp), INTENT(IN) :: z
REAL(dp)             :: lanczos

! Local variables

REAL(dp)  :: a(9) = (/ 0.9999999999995183_dp, 676.5203681218835_dp, &
                      -1259.139216722289_dp, 771.3234287757674_dp, &
                      -176.6150291498386_dp, 12.50734324009056_dp, &
                      -0.1385710331296526_dp, 0.9934937113930748D-05, &
                       0.1659470187408462D-06 /), zero = 0._dp,   &
                       one = 1._dp, lnsqrt2pi = 0.9189385332046727_dp, &
                       half = 0.5_dp, sixpt5 = 6.5_dp, seven = 7._dp, tmp
INTEGER  :: j

IF (z <= zero) THEN
  WRITE(*, *)'Error: zero or -ve argument for lngamma'
  RETURN
END IF

lanczos = zero
tmp = z + seven
DO j = 9, 2, -1
  lanczos = lanczos + a(j)/tmp
  tmp = tmp - one
END DO
lanczos = lanczos + a(1)
lanczos = LOG(lanczos) + lnsqrt2pi - (z + sixpt5) + (z - half)*LOG(z + sixpt5)
RETURN

END FUNCTION lngamma

FUNCTION KS2_asympt(n, d) RESULT( prob )
! Using Smirnov's asymptotic formaula for large N

INTEGER, INTENT(IN)    :: n
REAL (dp), INTENT(IN)  :: d
REAL (dp)              :: prob

! Local variables

REAL (dp)  :: sgn, sum, term, z
INTEGER    :: i
REAL (dp), PARAMETER  :: zero = 0.0_dp, one = 1.0_dp

z = d * SQRT( DBLE(n) )
sum = zero
i = 1
sgn = one
DO
  term = EXP( -2.0_dp * (i*z)**2 )
  sum = sum + sgn*term
  IF (term < EPSILON(one)) EXIT
  i = i + 1
  sgn = -sgn
END DO
prob = 2.0_dp*sum

RETURN
END FUNCTION KS2_asympt

END MODULE Kolmogorov_Smirnov


      subroutine gfun (n, t, y, g)
c This subroutine computes the right-hand side function g(y,t).
c It uses r4d = 1/(4*delta), eodsq = eta/delta**2, and nm1 = n - 1
c from the Common block test1.
c
      integer i, n, nm1
      double precision t, y, g, r4d, eodsq, two
      dimension g(n), y(n)
      common /test1/ r4d, eodsq, nm1
      data two/2.0d0/
c
      g(1) = -r4d*y(2)**2 + eodsq*(y(2) - two*y(1))
c
      do 20 i = 2,nm1
        g(i) = r4d*(y(i-1)**2 - y(i+1)**2)
     1        + eodsq*(y(i+1) - two*y(i) + y(i-1))
   20   continue
c
      g(n) = r4d*y(nm1)**2 + eodsq*(y(nm1) - two*y(n))
c
      return
c end of subroutine gfun for the DLSODI demonstration problem.
      end


      subroutine intp(x,xd,yd,n,nc,y)
c!purpose
c     linear interpolation computes y=F(x) for f a tabulated function
c      from R to R^n
c!parameters
c     x    : x given point
c     xd   : vector (nc) of abscissae mesh points (xd(i+1)>=xd(i))
c     yd   : matrix (nc x n): yd(i,j)=Fj(x(i))
c     n    : dimension of F image
c     returned values
c     y    : vector (n) :interpolated value of F(x)
c!remarks
c     if x<=xd(1) y=yd(1,:)
c     if x>=xd(nc) y=yd(nc,:)
      double precision x,xd(*),y(*),yd(nc,*)
      integer i, inter, n, nc
      i=0
      inter=0
c
      if (nc.eq.1) then
         call dcopy(n,yd(1,1),nc,y,1)
      elseif(x.ge.xd(nc)) then
         call dcopy(n,yd(nc,1),nc,y,1)
      elseif(x.le.xd(1)) then
         call dcopy(n,yd(1,1),nc,y,1)
      else
c     find x interval
         do 10 i=1,nc
            if (x.lt.xd(i)) then
               inter=i-1
               goto 20
            endif
 10      continue
 20      continue
c
c     compute interpolated y
c
         if (xd(inter+1).eq.xd(inter)) then
            call dcopy(n,yd(inter,1),nc,y,1)
         else
            do 40 i=1,n
               y(i)=yd(inter,i)+
     &              (x-xd(inter))*((yd(inter+1,i)-yd(inter,i))/
     &              (xd(inter+1)-xd(inter)))
 40         continue
         endif
      endif
      end


program main
    implicit none
    REAL :: a4, b4, c4, root1, root2, d4, p4, q4
    print*,'enter the 3 values of A, B, and C:'
    read*,a4, b4, c4
    d4=b4**2-4.0*a4*c4
    IF (d4>=0.00) THEN
        root1=-b4+sqrt(d4)
        root2=-b4-sqrt(d4)
    print*,'root one is=',root1
    print*,'root two is=',root2
    ELSE
        p4=-b4/(2.0*a4)
        q4=sqrt(abs(d4))
        print*,'1st root',p4,'+i',p4
        print*,'2st root',p4,'-i',q4
    END IF
end program main


module dispersions
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!# Contains definitions of the phonon dispersions.
!# Currently only simple acoustic branch for testing.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  use constants, only: real12, zero, two
  implicit none
  private
  public finedispersion, coarseDispersion

contains
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  elemental pure function fineDispersion(kx, ky, kz)
    complex(real12) :: fineDispersion
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!# Defines the momentum at each point using an acoustic dispersion
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    real(real12), intent(in) :: kx
    !# *x* momentum
    real(real12), intent(in) :: ky
    !# *y* momentum
    real(real12), intent(in) :: kz
    !# *z* momentum
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    fineDispersion = cmplx(sin(kx / two) * sin(kx / two)&
         + sin(ky / two) * sin(ky / two)&
         + sin(kz / two) * sin(kz / two), zero, real12)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  end function fineDispersion
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  function coarseDispersion(fineomega2, icellnumber, igridno)
    complex(real12) :: coarseDispersion
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!# Sums and normalises fine grid momenta from an input array.
!# Array fineomega2 must be *masked* to set non relevent contributions to zero.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    complex(real12), intent(in) :: fineomega2(:, :, :)
    !# fine grid omega values
    integer,intent(in)          :: icellnumber
    !# **total** number of coarse grid points
    integer, intent(in)         :: igridno
    !# **total** number of fine grid points
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! routine variables
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    real(real12)                :: ratio
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ratio = real(icellnumber, real12) / real(igridno, real12)

    coarseDispersion = ratio * sum(fineomega2)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  end function coarseDispersion
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
end module dispersions


!**********************************************************************
!   pi3f90.f - compute pi by integrating f(x) = 4/(1 + x**2)
!
!   Each node:
!    1) receives the number of rectangles used in the approximation.
!    2) calculates the areas of it's rectangles.
!    3) Synchronizes for a global summation.
!   Node 0 prints the result.
!
!  Variables:
!
!    pi  the calculated result
!    n   number of points of integration.
!    x           midpoint of each rectangle's interval
!    f           function to integrate
!    sum,pi      area of rectangles
!    tmp         temporary scratch space for global summation
!    i           do loop index
!****************************************************************************
program main

 use mpi

 double precision  PI25DT
 parameter        (PI25DT = 3.141592653589793238462643d0)

 double precision  mypi, pi, h, sum, x, f, a
 integer n, myid, numprocs, i, rc
!                                 function to integrate
 f(a) = 4.d0 / (1.d0 + a*a)

 call MPI_INIT( ierr )
 call MPI_COMM_RANK( MPI_COMM_WORLD, myid, ierr )
 call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, ierr )
 print *, 'Process ', myid, ' of ', numprocs, ' is alive'

 sizetype   = 1
 sumtype    = 2

 do
    if ( myid .eq. 0 ) then
       write(6,98)
 98    format('Enter the number of intervals: (0 quits)')
       read(5,99) n
 99    format(i10)
    endif

    call MPI_BCAST(n,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr)

!                                 check for quit signal
    if ( n .le. 0 ) exit

!                                 calculate the interval size
    h = 1.0d0/n

    sum  = 0.0d0
    do i = myid+1, n, numprocs
       x = h * (dble(i) - 0.5d0)
       sum = sum + f(x)
    enddo
    mypi = h * sum

!                                 collect all the partial sums
    call MPI_REDUCE(mypi,pi,1,MPI_DOUBLE_PRECISION,MPI_SUM,0, &
                    MPI_COMM_WORLD,ierr)

!                                 node 0 prints the answer.
    if (myid .eq. 0) then
        write(6, 97) pi, abs(pi - PI25DT)
 97     format('  pi is approximately: ', F18.16, &
               '  Error is: ', F18.16)
    endif

 enddo

 call MPI_FINALIZE(rc)
 stop
end


      subroutine somm (dr,dp,dq,dpas,da,m,np)
c
c integration by the method of simpson of (dp+dq)*dr**m from
c 0 to r=dr(np)
c dpas=exponential step;
c for r in the neighborhood of zero (dp+dq)=cte*r**da
c **********************************************************************
      implicit double precision (a-h,o-z)
      dimension dr(np), dp(np), dq(np)
      mm=m+1
      d1=da+mm
      da=0.d0
      db=0.d0
      do i=1,np
         dl=dr(i)**mm
         if (i.eq.1.or.i.eq.np) go to 10
         dl=dl+dl
         if ((i-2*(i/2)).eq.0) dl=dl+dl
 10      continue
         dc=dp(i)*dl
         if (dc.lt.0) then
            db=db+dc
         else if (dc.gt.0) then
            da=da+dc
         endif
         dc=dq(i)*dl
         if (dc.lt.0) then
            db=db+dc
         else if (dc.gt.0) then
            da=da+dc
         endif
      enddo
      da = dpas * (da + db) / 3.d0
      dc=exp(dpas)-1.d0
      db=d1*(d1+1.d0)*dc*exp((d1-1.d0)*dpas)
      db=dr(1)*(dr(2)**m)/db
      dc=(dr(1)**mm)*(1.d0+1.d0/(dc*(d1+1.d0)))/d1
      da=da+dc*(dp(1)+dq(1))-db*(dp(2)+dq(2))
      return
      end


program main
  use numeric_kinds, only: dp

  use davidson, only: generalized_eigensolver
  use array_utils, only: generate_diagonal_dominant
  use test_utils, only: apply_mtx_to_vect, apply_stx_to_vect, compute_matrix_on_the_fly, &
       compute_stx_on_the_fly, write_matrix, write_vector

  implicit none

  integer, parameter :: dim = 50
  integer, parameter :: lowest = 3
  real(dp), dimension(3) :: eigenvalues_DPR
  real(dp), dimension(dim, 3) :: eigenvectors_DPR
  real(dp), dimension(dim, dim) :: mtx, stx
  integer :: iter_i, j

  do j=1, dim
     mtx(:, j) = compute_matrix_on_the_fly(j, dim)
     stx(:, j) = compute_stx_on_the_fly(j, dim)
  end do

  ! Write matrices down to test the eigenvalues against numpy
  call write_matrix("matrix_free.txt", mtx)
  call write_matrix("stx_free.txt", stx)

  call generalized_eigensolver(apply_mtx_to_vect, eigenvalues_DPR, eigenvectors_DPR, lowest, &
       "DPR", 1000, 1d-8, iter_i, 20, apply_stx_to_vect)

  call write_vector("eigenvalues_DPR_free.txt",eigenvalues_DPR)
  call write_matrix("eigenvectors_DPR_free.txt", eigenvectors_DPR)

end program main


C-----------------------------------------------------------------------
      SUBROUTINE EFERMI (NEL,NBANDS,DEL,NSPPTS,NDIM8,NDIM10,
     +          WEIGHT,OCC,EF,EIGVAL,SORT,eigmin,eigmax,enocc,ismear)
C-----------------------------------------------------------------------

C     FERMI ENERGY & SMEARING PACKAGE REWRITTEN IN FINAL FORM FOR
C     CASTEP/CETEP USE BY A. DE VITA IN JULY 1992, STARTING FROM
C     R. NEEDS VERSION
C
C     COLD SMEARING, SPLINE OF GAUSSIANS, AND A CORRECTION TO METH-PAX
C     INTRODUCED BY N. MARZARI (1995)
C
C     FOR A DETAILED EXPLANATION OF THE SMEARING APPROACH, LOOK AT
C     N. MARZARI PhD THESIS, CHAPTER 4, AND REFERENCES THEREIN:
C     http://theossrv1.epfl.ch/uploads/Group/Bibliography/Nicola%20Marzari_these_04-1996.pdf
C
C     Cold smearing reference: N. Marzari, D. Vanderbilt, A. De Vita
C     and M. C. Payne, ``Thermal contraction and disordering of the
C     Al(110) surface'', Phys. Rev. Lett. 82, 3296 (1999).
C
C     GIVEN A SET OF WEIGHTS AND THE EIGENVALUES ASSOCIATED TO THEIR
C     ASSOCIATED K-POINTS FOR BZ SAMPLING, THIS SUBROUTINE PERFORMS
C     TWO TASKS:
C
C     (1) DETERMINES THE FERMI LEVEL AND THE OCCUPANCY OF THE STATES
C         ACCORDING TO CHOSEN SMEARING SCHEME

C     (2) DETERMINES THE "ENTROPY CORRECTION" TO BE ADDED TO
C         THE TOTAL ENERGY FOR RECOVERING THE ZERO-SMEARING ENERGY
C         (I.E. THE TRUE GROUND STATE ENERGY) AND PASSES IT BACK TO
C         THE MAIN CODE. NOTE THAT THIS IS NOT NEEDED FOR METH-PAX
C         OR THE COLD SMEARING
C
C     THE SMEARING SCHEMES (CHOOSE ONE WITH PARAMETER ISMEAR):
C
C     (1) GAUSSIAN:
C     SEE: C-L FU AND K-M HO, PHYS. REV. B 28, 5480 (1983).
C     THEIR IMPLEMENTATION WAS VARIATIONAL BUT *NOT* CORRECTED FOR
C     SECOND ORDER DEVIATION IN SIGMA AS ALSO WAS THE SIMILAR SCHEME
C     (WITH OPPOSITE SIGN DEVIATION) IN: R.J.NEEDS, R.M.MARTIN AND O.H.
C     NIELSEN, PHYS. REV. B 33 , 3778 (1986).
C     USING THE CORRECTION CALCULATED HEREAFTER EVERYTHING SHOULD BE OK.
C     THE SMEARING FUNCTION IS A GAUSSIAN NORMALISED TO 2.
C     THE OCCUPATION FUNCTION IS THE ASSOCIATED COMPLEMENTARY
C     ERROR FUNCTION.
C
C     (2) FERMI-DIRAC:
C     SEE: M.J.GILLAN J. PHYS. CONDENS. MATTER 1, 689 (1989), FOLLOWING
C     THE SCHEME OUTLINED IN J.CALLAWAY AND N.H.MARCH, SOLID STATE PHYS. 38,
C     136 (1984), AFTER D.N.MERMIN, PHYS. REV 137, A1441 (1965).
C     THE OCCUPATION FUNCTION IS TWICE THE SINGLE ELECTRON
C     FERMI-DIRAC DISTRIBUTION.
C
C     (3) HERMITE-DELTA_EXPANSION:
C     SEE: METHFESSEL AND PAXTON, PHYS. REV.B 40, 3616 (1989).
C     THE SMEARING FUNCTION IS A TRUNCATED EXPANSION OF DIRAC'S DELTA
C     IN HERMITE POLINOMIALS.
C     FOR THE SMEARING FUNCTION IMPLEMENTED HERE THE TRUNCATION IS
C     AT THE FIRST NON-TRIVIAL EXPANSION TERM D1(X).
C     THE OCCUPATION FUNCTION IS THE ASSOCIATED PRIMITIVE.
C     (NOTE: THE OCCUPATION FUNCTION IS NEITHER MONOTONIC NOR LIMITED
C     BETWEEN 0. AND 2. : PLEASE CHECK THE COMPATIBILITY OF THIS WITH
C     YOUR CODE'S VERSION AND VERIFY IN A TEST CALCULATION THAT THE
C     FERMI LEVEL IS *UNIQUELY* DETERMINED).
C
C     THE ENTROPY CORRECTION HOLDS UP TO THE THIRD ORDER IN DELTA AT LEAST,
C     AND IS NOT NECESSARY (PUT = 0.) FOR THE HERMITE_DELTA EXPANSION,
C     SINCE THE LINEAR ENTROPY TERM IN SIGMA IS ZERO BY CONSTRUCTION
C     IN THAT CASE. (well, we still need the correct free energy. hence
C     delcor is set to its true value, nmar)
C
C     (4) GAUSSIAN SPLINES:
C     similar to a Gaussian smearing, but does not require the
C     function inversion to calculate the gradients on the occupancies.
C     It is thus to be preferred in a scheme in which the occ are
C     independent variables (not in castep/cetep) (N. Marzari)
C
C     (5) POSITIVE HERMITE, or COLD SMEARING I
C     similar to Methfessel-Paxton (that is killing the linear order
C     in the entropy), but with positive-definite occupations (still
C     greater than 1) ! (N. Marzari)
C
C     (6) POSITIVE HERMITE, or COLD SMEARING II: the one to use.
C     (5) and (6) are practically identical; (6) is more elegant.
C     Phys. Rev. Lett. 82, 3296 (1999).

C------------------
C     **** PLEASE INQUIRE WITH ADV/NMAR FOR REFERENCE & SUGGESTIONS IF
C     YOU PLAN TO USE THE PRESENT CORRECTED BZ SAMPLING SCHEME ****
C     nicola.marzari@epfl.ch (was marzari@princeton.edu)
C     alessandro.de_vita@kcl.ac.uk (was alessandro.devita@epfl.ch)
C------------------

C     NEL ..... NUMBER OF ELECTRONS PER UNIT CELL
C     NBANDS .. NUMBER OF BANDS FOR EACH K-POINT
C     DEL ..... WIDTH OF GAUSSIAN SMEARING FUNCTION
C     NSPPTS .. NUMBER OF K-POINTS
C     NDIM8 ... MAXIMUM NUMBER OF BANDS AT A K-POINT
C     WEIGHT .. THE WEIGHT OF EACH K-POINT
C     OCC ..... THE OCCUPANCY OF EACH STATE
C     EF ...... THE FERMI ENERGY
C     SORT .... THE EIGENVALUES ARE WRITTEN INTO SORT WHICH IS
C               THEN SORTED INTO ASCENDING NUMERICAL VALUE, FROM
C               WHICH BOUNDS ON EF CAN EASILY BE OBTAINED
C     EIGVAL .. CONTAINS THE BEST EIGENVALUES AVAILABLE
c
c    ISMEAR = 1 GAUSSIAN BROADENING
C           = 2 FERMI-DIRAC BROADENING
C           = 3 HERMITE EXPANSION (1ST ORD.) (right delcor now, nmar)
C           = 4 SPLINE OF GAUSSIANS (nmar)
C           = 5 COLD SMEARING I (nmar)
C           = 6 COLD SMEARING II (nmar)
C     JMAX      THE MAX NUMBER OF BISECTIONS TO GET EF
C     XACC      THE DESIRED ACCURACY ON EF
C
C     DELCOR    THE CORRECTION. PASSED BACK IN SORT(1) (= SORT(1,1))
C               TO BE COMPATIBLE WITH OLD VERSIONS OF THE CODE. IF
C               YOUR CODE DOES NOT DO IT ALREADY, ADD SORT(1) TO
C               CORRECT THE TOTAL ENERGY IN YOUR MAIN.FORTRAN , WHICH
C               SHOULD CALL ANYWAY THIS ROUTINE CORRECTLY.
C
C     CHANGED: -TS goes into enocc (nmar)
C     also: the correction is needed for 1,2 and 4 only
C-------------------------------------------------------------
c     ANOTHER NOTE:
C     Thanks to the possible > 2 or < 0
c     orbital occupancies in the general case of smearing function,
c     (e.g. in the M-P case) the algorithm to find EF has been
c     chosen to be the robust bisection method (from Numerical
c     Recipes) to allow for non monotonic relation between total
c     NEL (see above) and EF. One value for EF which solves
c     NEL(EF) - Z = 0   is always found.
C---------------------------------------------------------------------
C
      IMPLICIT REAL (A-H,O-Z)

      DIMENSION SORT(NDIM8*NDIM10)
      DIMENSION OCC(NDIM8,NDIM10),WEIGHT(NDIM10),EIGVAL(NDIM8,NDIM10)
      EXTERNAL ERF_C
      EXTERNAL FERMID
      EXTERNAL DELTHM
      EXTERNAL POSHM
      EXTERNAL POSHM2
C.....WARNINGS
      COMMON /WARN/ IWARN
      PARAMETER ( JMAX =200, XACC=1.0D-10)
C.....WHICH SMEARING IS USED

      pi=acos(0.0)*2.0
      ee=exp(1.0)
      eesh=sqrt(ee)*0.5
      sq2i=sqrt(2.0)*0.5
      piesqq=sqrt(ee*pi)*0.25

      Z    = FLOAT(NEL)

C COPY EIGVAL INTO SORT ARRAY.

      NEIG = 0
      DO 10 ISPPT = 1,NSPPTS
        DO 20  J = 1, NBANDS
          NEIG = NEIG + 1
20        SORT(NEIG) = EIGVAL(J,ISPPT)
10      CONTINUE

C=======================================================================
C  THE ARRAY IS ORDERED INTO ASCENDING ORDER OF EIGENVALUE
C=======================================================================

      DO 26 N=2,NSPPTS*NBANDS
        EN=SORT(N)
        DO 22 NN=N-1,1,-1
          IF (SORT(NN).LE.EN) GO TO 24
          SORT(NN+1)=SORT(NN)
  22    CONTINUE
        NN=0
  24    SORT(NN+1)=EN
  26  CONTINUE
      eigmin=sort(1)
      eigmax=sort(nsppts*nbands)

C===========================
C     THE UPPER BOUND XE2 AND THE LOWER BOUND XE1
C     ARE PUT TO FIRST AND LAST EIGENVALUE, THEN
C     THE ACTUAL FERMI ENERGY IS FOUND BY BISECTION
C===========================

      XE1=ef-del
      XE2=ef+0.5*del
      xe0=ef

C
c           WRITE(*,*) ' '
          IF(ISMEAR.EQ.1) THEN
            WRITE(*,*) 'GAUSSIAN BROADENING'
          ELSEIF(ISMEAR.EQ.2) THEN
            WRITE(*,*) 'FERMI-DIRAC BROADENING'
          ELSEIF(ISMEAR.EQ.3) THEN
            WRITE(*,*) 'HERMITE-DIRAC BROADENING'
          ELSEIF(ISMEAR.EQ.4) THEN
            WRITE(*,*) 'GAUSSIAN SPLINES BROADENING'
          ELSEIF(ISMEAR.EQ.5) THEN
            WRITE(*,*) 'COLD SMEARING I'
          ELSEIF(ISMEAR.EQ.6) THEN
            WRITE(*,*) 'COLD SMEARING II'
          ENDIF
c     WRITE (9,*) '                  '
c     WRITE (9,*) 'min & max eigval ',eigmin,eigmax

      nmax=1
100   continue

C
C FMID = FUNC(X2) in Numerical Recipes.
C
      Z1=0.D0
      DO 40 ISPPT = 1,NSPPTS
        DO 50 J = 1,NBANDS
          X = (XE2 - EIGVAL(J,ISPPT))/DEL
          IF(ISMEAR.EQ.1) THEN
            Z1 = Z1 + WEIGHT(ISPPT)*( 2.0 - ERF_C(X) )
          ELSEIF(ISMEAR.EQ.2) THEN
            Z1 = Z1 + WEIGHT(ISPPT)*FERMID(-X)
          ELSEIF(ISMEAR.EQ.3) THEN
            Z1 = Z1 + WEIGHT(ISPPT)*DELTHM(X)
          ELSEIF(ISMEAR.EQ.4) THEN
            Z1 = Z1 + WEIGHT(ISPPT)*SPLINE(-X)
          ELSEIF(ISMEAR.EQ.5) THEN
            Z1 = Z1 + WEIGHT(ISPPT)*POSHM(X)
          ELSEIF(ISMEAR.EQ.6) THEN
            Z1 = Z1 + WEIGHT(ISPPT)*POSHM2(X)
          ENDIF
50      CONTINUE
40    CONTINUE

      FMID= Z1-Z

C F = FUNC(X1)

      Z1=0.D0
      DO 140 ISPPT = 1,NSPPTS
        DO 150 J = 1,NBANDS
          X = (XE1 - EIGVAL(J,ISPPT))/DEL
          IF(ISMEAR.EQ.1) THEN
            Z1 = Z1 + WEIGHT(ISPPT)*( 2.0 - ERF_C(X) )
          ELSEIF(ISMEAR.EQ.2) THEN
            Z1 = Z1 + WEIGHT(ISPPT)*FERMID(-X)
          ELSEIF(ISMEAR.EQ.3) THEN
            Z1 = Z1 + WEIGHT(ISPPT)*DELTHM(X)
          ELSEIF(ISMEAR.EQ.4) THEN
            Z1 = Z1 + WEIGHT(ISPPT)*SPLINE(-X)
          ELSEIF(ISMEAR.EQ.5) THEN
            Z1 = Z1 + WEIGHT(ISPPT)*POSHM(X)
          ELSEIF(ISMEAR.EQ.6) THEN
            Z1 = Z1 + WEIGHT(ISPPT)*POSHM2(X)
          ENDIF
150     CONTINUE
140   CONTINUE

      F= Z1-Z

      IF(F*FMID .GE. 0.D0) THEN
        if (nmax.ge.10000) then
         WRITE(*,*) 'ERROR: NO FERMI ENERGY FOUND ',
     &             xe1,xe2,f,fmid,nmax
         WRITE(*,*) ' '
         WRITE(*,*) 'IS THE ELECTRONIC TEMPERATURE TOO SMALL ? ',del
         WRITE(*,*) ' '
         stop
        else
         nmax=nmax+1
         XE1=XE0-float(nmax)*del
         XE2=XE0+(float(nmax)-0.5)*del
         goto 100
        end if
      ENDIF
      IF(F .LT. 0.D0) THEN
       RTBIS = XE1
       DX = XE2 - XE1
      ELSE
       RTBIS = XE2
       DX = XE1 - XE2
      ENDIF
      DO 42 J = 1, JMAX
       DX = DX * 0.5D0
       XMID = RTBIS + DX

C FMID=FUNC(XMID)

      Z1=0.D0
      DO 240 ISPPT = 1,NSPPTS
        DO 250 J2 = 1,NBANDS
          X = (XMID - EIGVAL(J2,ISPPT))/DEL
          IF(ISMEAR.EQ.1) THEN
            Z1 = Z1 + WEIGHT(ISPPT)*( 2.0 - ERF_C(X) )
          ELSEIF(ISMEAR.EQ.2) THEN
            Z1 = Z1 + WEIGHT(ISPPT)*FERMID(-X)
          ELSEIF(ISMEAR.EQ.3) THEN
            Z1 = Z1 + WEIGHT(ISPPT)*DELTHM(X)
          ELSEIF(ISMEAR.EQ.4) THEN
            Z1 = Z1 + WEIGHT(ISPPT)*SPLINE(-X)
          ELSEIF(ISMEAR.EQ.5) THEN
            Z1 = Z1 + WEIGHT(ISPPT)*POSHM(X)
          ELSEIF(ISMEAR.EQ.6) THEN
            Z1 = Z1 + WEIGHT(ISPPT)*POSHM2(X)
          ENDIF
250     CONTINUE
240   CONTINUE

      FMID= Z1-Z

      IF(FMID .LE. 0.D0) RTBIS=XMID
      IF(ABS(DX) .LT. XACC .OR. FMID .EQ. 0) THEN
       GOTO 1042
      ENDIF
  42  CONTINUE
        WRITE(*,*) 'CANNOT BISECT FOREVER, CAN I ?'
c       WRITE(9,*) 'CANNOT BISECT FOREVER, CAN I ?'
        STOP

1042  EF = RTBIS

170   CONTINUE

      WRITE (*,180) EF
c     WRITE (9,180) EF
180   FORMAT (' FERMI ENERGY = ',F15.8,' EV')

C     FORM OCCUPATIONS OCC(NBDS,NSPPTS)
      DO 190 ISPPT = 1, NSPPTS
        DO 200 J = 1,NBANDS
          X = ( EF-EIGVAL(J,ISPPT))/DEL
          IF(ISMEAR.EQ.1) THEN
            OCC(J,ISPPT) = 2.0 - ERF_C(X)
          ELSEIF(ISMEAR.EQ.2) THEN
            OCC(J,ISPPT) = FERMID(-X)
          ELSEIF(ISMEAR.EQ.3) THEN
            OCC(J,ISPPT) = DELTHM(X)
          ELSEIF(ISMEAR.EQ.4) THEN
            OCC(J,ISPPT) = SPLINE(-X)
          ELSEIF(ISMEAR.EQ.5) THEN
            OCC(J,ISPPT) = POSHM(X)
          ELSEIF(ISMEAR.EQ.6) THEN
            OCC(J,ISPPT) = POSHM2(X)
          ENDIF
            OCC(J,ISPPT) = OCC(J,ISPPT)/2.0
200     CONTINUE
190   CONTINUE

C-------------------------------------------------------------
C CALCULATES THE CORRECTION TERM TO GET "0 TEMPERATURE" ENERGY
C-------------------------------------------------------------

      DELCOR=0.0D0
      DO 191 ISPPT = 1, NSPPTS
       DO 201 J = 1,NBANDS
        X = ( EF-EIGVAL(J,ISPPT))/DEL
        IF(ISMEAR.EQ.1) THEN
         DELCOR=DELCOR
     &    -DEL*WEIGHT(ISPPT)*EXP(-X*X)/(2.D0*SQRT(pi))
        ELSEIF(ISMEAR.EQ.2) THEN
         FI=FERMID(-X)/2.D0
         IF(ABS(FI) .GT. 1.E-06) THEN
          IF(ABS(FI-1.D0) .GT. 1.E-06) THEN
           DELCOR=DELCOR+DEL*WEIGHT(ISPPT)*
     &     (FI*LOG(FI)+(1.D0-FI)*LOG(1.D0-FI))
          ENDIF
         ENDIF
        ELSEIF(ISMEAR.EQ.3) THEN
         DELCOR=DELCOR+DEL/2.0*WEIGHT(ISPPT)
     &    *(2.0*x*x-1)*exp(-x*x)/(2.0*sqrt(pi))
        ELSEIF(ISMEAR.EQ.4) THEN
         x=abs(x)
         zeta=eesh*abs(x)*exp(-(x+sq2i)**2)+piesqq*ERF_C(x+sq2i)
         delcor=delcor-del*WEIGHT(ISPPT)*zeta
        ELSEIF(ISMEAR.EQ.5) THEN
         a=-0.5634
c        a=-0.8165
         DELCOR=DELCOR-DEL/2.0*WEIGHT(ISPPT)
c NOTE g's are all intended to be normalized to 1 !
c this following line is -2*int_minf^x [t*g(t)]dt
     &   *(2.0*a*x**3-2.0*x*x+1 )*exp(-x*x)/(2.0*sqrt(pi))
        ELSEIF(ISMEAR.EQ.6) THEN
         DELCOR=DELCOR-DEL/2.0*WEIGHT(ISPPT)
c NOTE g's are all intended to be normalized to 1 !
c this following line is -2*int_minf^x [t*g(t)]dt
     &   *(1-sqrt(2.0)*x)*exp(-(x-1/sqrt(2.))**2)/sqrt(pi)
        ENDIF
201    CONTINUE
191   CONTINUE

c--------------------------------------------------------
C  the correction stored in enocc
c--------------------------------------------------------

      sort(1)=delcor
      enocc=2.0*delcor

c--------------------------------------------------------
c     TEST WHETHER OCCUPANCY ADDS UP TO Z
c--------------------------------------------------------

      TEST = 0.0
      DO 210 ISPPT = 1,NSPPTS
        DO 215 J = 1,NBANDS
215       TEST = TEST + WEIGHT(ISPPT)*OCC(J,ISPPT)
210     CONTINUE
      test=test*2.0

c--------------------------------------------------------
c UNCOMMENT IF YOU WISH to see occupation numbers at each kpoint
c--------------------------------------------------------

      DO 193 ISPPT = 1, NSPPTS

c         WRITE (*,9897) ISPPT
c         WRITE (9,9897) ISPPT
9897  FORMAT(' OCCUPATION NUMBERS AT K-POINT',I3,':')
c         WRITE(*,9898) (OCC(J,ISPPT),J=1,NBANDS)
c         WRITE(9,9898) (OCC(J,ISPPT),J=1,NBANDS)
9898  FORMAT(2X,5F15.6)
193     CONTINUE

      IF ( ABS(TEST-Z) .GT. 1.0D-5) THEN

C        WRITE(*,*) '*** ERROR ***'
        WRITE(*,*) '*** Warning ***'
        WRITE(*,220) TEST,NEL
220     FORMAT(' SUM OF OCCUPANCIES =',F18.12 ,' BUT NEL =',I5)
C        STOP     !! Modified by A. Marrazzo and G. Prandini
C		  !! to do bands convergence tests.
C

      ELSE

c       WRITE(*,230) TEST
c       WRITE(*,*) ' '
230     FORMAT(' TOTAL CHARGE = ',F15.8)

      ENDIF
C
C     TEST WHETHER THE MATERIAL IS A SEMICONDUCTOR
C     (ASSUMING SPIN DEGENERACY)
C
C     this has to be sorted out better
C
      IF ( MOD( NEL, 2) .EQ. 1) RETURN
      INEL = NEL/2
      if (inel+1.le.ndim8) then
       ELOW = EIGVAL(INEL+1,1)
       DO 310 ISPPT = 2,NSPPTS
         ELOW =MIN( ELOW, EIGVAL(INEL+1,ISPPT))
310    CONTINUE
       DO 320 ISPPT = 1,NSPPTS
        IF (ELOW .LT. EIGVAL(INEL,ISPPT)) RETURN
320    CONTINUE
      end if

      if (NSPPTS.gt.1) then
       WRITE (*,*) 'MATERIAL MAY BE A SEMICONDUCTOR'
      end if
C
      RETURN
      END
C
C =========================================================================
C
      FUNCTION ERF_C(XX)
C
C     COMPLEMENTARY ERROR FUNCTION
C     FROM THE SANDIA MATHEMATICAL PROGRAM LIBRARY
C
C     XMAX IS THE VALUE BEYOND WHICH ERF_C(X) = 0 .
C     IT IS COMPUTED AS SQRT(LOG(RMIN)), WHERE RMIN IS THE
C     SMALLEST REAL NUMBER REPRESENTABLE ON THE MACHINE.
C     IBM VALUE: (THE INTRINSIC ERF_C COULD ALSO BE USED)
C     PARAMETER ( XMAX = 13.4 )
C     VAX VALUE: (XMAX = 9.3)
C -----------------------------------
C     12-Mar-90  Obtained from B. Hammer
C     12-MAR-90  Changed to single precision at the end XW
C                also XX1
      PARAMETER ( XMAX = 9.3D0)
C
C      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION P1(4),Q1(4),P2(6),Q2(6),P3(4),Q3(4)
C
      DATA P1 /242.66 79552 30531 8D0 , 21.979 26161 82941 5D0 ,
     + 6.9963 83488 61913 6D0 , -3.5609 84370 18153 9D-2/
      DATA Q1 /215.05 88758 69861 2D0 , 91.164 90540 45149 0D0,
     + 15.082 79763 04077 9D0 , 1.0D0/
      DATA P2 /22.898 99285 1659D0 , 26.094 74695 6075D0 ,
     + 14.571 89859 6926D0 , 4.2677 20107 0898D0 ,
     + 0.56437 16068 6381D0 , -6.0858 15195 9688 D-6/
      DATA Q2 /22.898 98574 9891D0 , 51.933 57068 7552D0 ,
     + 50.273 20286 3803D0 , 26.288 79575 8761D0 ,
     + 7.5688 48229 3618D0 , 1.0D0/
      DATA P3 /-1.2130 82763 89978 D-2 , -0.11990 39552 68146 0D0 ,
     + -0.24391 10294 88626D0 , -3.2431 95192 77746 D-2/
      DATA Q3 /4.3002 66434 52770 D-2 , 0.48955 24419 61437D0 ,
     + 1.4377 12279 37118D0 , 1.0D0/
C     1/SQRT(PI)
      DATA SQPI /0.56418 95835 47756D0/
C
C----------------------------------------------------------------------
      IF (XX .GT.  XMAX)    GOTO 330
      IF (XX .LT. -XMAX)    GOTO 320
      X = ABS(XX)
      X2 = X*X
      IF (X .GT. 4.0D0)     GOTO 300
      IF (X .GT. 0.46875D0) GOTO 200
C
C     -46875 < X < 0.46875
      ERF_C = X*(P1(1) + X2*(P1(2) + X2*(P1(3) + X2*P1(4))))
      ERF_C = ERF_C/(Q1(1) + X2*(Q1(2) + X2*(Q1(3) + X2*Q1(4))))
      IF (XX .LT. 0.0) ERF_C = - ERF_C
      ERF_C = 1.0D0 - ERF_C
      GOTO 9999
C
200   ERF_C = EXP( -X2)*(P2(1) + X*(P2(2) + X*(P2(3) + X*(P2(4) +
     + X*(P2(5) + X*P2(6))))))
      ERF_C = ERF_C/(Q2(1) + X*(Q2(2) + X*(Q2(3) + X*(Q2(4) + X*(Q2(5) +
     + X*Q2(6))))))
      IF (XX .LE. 0.0) ERF_C = 2.0D0 - ERF_C
      GOTO 9999
C
300   XI2 = 1.0D0/X2
      ERF_C = XI2*(P3(1) + XI2*(P3(2) + XI2*(P3(3) + XI2*P3(4))))/
     + (Q3(1) + XI2*(Q3(2) + XI2*(Q3(3) + XI2*Q3(4))))
      ERF_C = EXP( -X2)*(SQPI + ERF_C)/X
      IF (XX .LT. 0.0) ERF_C = 2.0D0 - ERF_C
      GOTO 9999
C
320   ERF_C = 2.0D0
      GOTO 9999
330   ERF_C = 0.0D0
C
9999  RETURN
      END
C================================================================
      FUNCTION FERMID(XX)
C
      IF(XX .GT. 30.D0) THEN
        FERMID=0.D0
      ELSEIF(XX .LT. -30.D0) THEN
        FERMID=2.D0
      ELSE
        FERMID=2.D0/(1.D0+EXP(XX))
      ENDIF
C
      RETURN
      END
C================================================================
      FUNCTION DELTHM(XX)
C
      pi=3.14159265358979
      IF(XX .GT. 10.D0) THEN
        DELTHM=2.D0
      ELSEIF(XX .LT. -10.D0) THEN
        DELTHM=0.D0
      ELSE
        DELTHM=(2.D0-ERF_C(XX))+XX*EXP(-XX*XX)/SQRT(PI)
      ENDIF
C
      RETURN
      END
C================================================================
      FUNCTION SPLINE(X)

      eesqh=sqrt(exp(1.0))*0.5
      sq2i=sqrt(2.0)*0.5
      if (x.ge.0.0) then
        fx=eesqh*exp(-(x+sq2i)**2)
      else
        fx=1.0-eesqh*exp(-(x-sq2i)**2)
      endif
      spline=2.0*fx
c
      return
      end
C================================================================
      FUNCTION POSHM(X)
C
c NOTE g's are all intended to be normalized to 1 !
C function = 2 * int_minf^x [g(t)] dt
C
      pi=3.141592653589793238
      a=-0.5634
c     a=-0.8165
      IF(X .GT. 10.D0) THEN
        POSHM=2.D0
      ELSEIF(X .LT. -10.D0) THEN
        POSHM=0.D0
      ELSE
        POSHM=(2.D0-ERF_C(X))+(-2.0*a*x*x+2*x+a)*EXP(-X*X)/SQRT(PI)/2.0
      ENDIF
C
      RETURN
      END
C================================================================
      FUNCTION POSHM2(X)
C
c NOTE g's are all intended to be normalized to 1 !
C function = 2 * int_minf^x [g(t)] dt
C
      pi=3.141592653589793238
      IF(X .GT. 10.D0) THEN
        POSHM2=2.D0
      ELSEIF(X .LT. -10.D0) THEN
        POSHM2=0.D0
      ELSE
        POSHM2=(2.D0-ERF_C(X-1./sqrt(2.)))+
     &  sqrt(2.)*exp(-x*x+sqrt(2.)*x-0.5)/sqrt(pi)
      ENDIF
C
      RETURN
      END
c===========================WELLWELLWEHAVEFINISHED.


      subroutine plglmax(lmax,x,plm)
c     ****************************************************************
c     Associated Legendre function....................................
c     Calclates all the p(l,m)'s up to lmax...........................
c     based on the formulae given in "Numerical Recipes" pages 180-183
c     (Equations 6.6.7, 6.6.8 and 6.6.9...............................
c     W. H. Press, B. P. Flannery, S A Teukolsky and W. T. Vetterling.
c     Cambridge Univ Press 1986.......................................
c     ****************************************************************
c
c Inputs:   lmax    integer scalar, max l for Plm
c           x       real*8 scalar, argument of Plm(x)
c Returns:  plm     real*8 array of ((lmax+1)*(lmax+2)/2), Plm(x)
c
      implicit   none
c
      integer    lmax
      integer    l,ll
      integer    m,mm
      integer    i
c
      real*8     plm((lmax+1)*(lmax+2)/2)
      real*8     x
      real*8     pmm
      real*8     somx2
      real*8     fact
      real*8     zero
      real*8     one
      real*8     tol
      real*8     two
c
      parameter  (zero=0.0d0)
      parameter  (one=1.0d0)
      parameter  (two=2.0d0)
      parameter  (tol=1.d-12)
c
c     ================================================================
      if(lmax.lt.0 .or. abs(x).gt.(one+tol)) then
         write(6,'(''plglmax:: bad arguments: lmax='',i5,'' x='',
     >         d14.6)') lmax,x
         stop'plglmax'
      endif
!      write(6,*) "plglmax: x=",x," lmax=",lmax
c
      if((one-abs(x)).le.tol) then
c        -------------------------------------------------------------
         call zeroout(plm,(lmax+1)*(lmax+2)/2)
c        -------------------------------------------------------------
	 if(x.lt.zero) then
            do l=0,lmax
	       i=(l+1)*(l+2)/2-l
	       plm(i)=one-two*mod(l,2)
            enddo
         else
            do l=0,lmax
	       i=(l+1)*(l+2)/2-l
	       plm(i)=one
            enddo
         endif
         return
      endif
c
c     ================================================================
c     begin calculation of p(l,m)'s...................................
      if(lmax.eq.0) then
c        =============================================================
c        special case lmax=0..........................................
         plm(1)=one
      else
c        =============================================================
c        minus sign added to be consistant with Numerical Recipes
c        which has (-1)^m factor in plm :  July 97  by xgz.............
c        =============================================================
         somx2=-sqrt((one-x)*(one+x))
         if(lmax.eq.1) then
c           ==========================================================
c           special case lmax=1.......................................
            plm(1)=one
            plm(2)=x
            plm(3)=somx2
         else
            do m=0,lmax
c              =======================================================
c                                       m       m
c              calculate the first two P   and P
c                                       m       m+1
c              =======================================================
               if(m.eq.0) then
                  plm(1)=one
                  plm(2)=x
               else
                  pmm=somx2
                  fact=one
                  do i=2,m
                     fact=fact+two
                     pmm=pmm*fact*somx2
                  enddo
		  mm=(m+1)*(m+2)/2
                  plm(mm)=pmm
                  if( mm+m+1.le.(lmax+1)*(lmax+2)/2 ) then
                     plm(mm+m+1)=x*(2*m+1)*pmm
                  end if
               endif
c              =======================================================
c                                  m        m
c              calculate the rest P     to P
c                                  m+2      lmax
c              =======================================================
               ll=(m+2)*(m+1)/2
               fact=(two*m+one)*x
               do l=m+2,lmax
                  pmm=(l+m-1)*plm(ll)
                  fact=fact+two*x
                  ll=ll+l-1
                  plm(ll+l)=( fact*plm(ll) - pmm )/dble(l-m)
               enddo
            enddo
         endif
      endif
c
      return
      end


    Program dgesvj_example

!     DGESVJ Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: ddisna, dgesvj
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: eps, serrbd
      Integer :: i, ifail, info, j, lda, ldv, lwork, m, n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), rcondu(:), rcondv(:), s(:), &
        v(:, :), work(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs, epsilon
!     .. Executable Statements ..
      Write (nout, *) 'DGESVJ Example Program Results'
      Write (nout, *)
      Flush (nout)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) m, n
      lda = m
      ldv = n
      lwork = n + m
      Allocate (a(lda,n), rcondu(m), rcondv(m), s(n), v(ldv,n), work(lwork))

!     Read the m by n matrix A from data file

      Read (nin, *)((a(i,j),j=1,n), i=1, m)

!     Compute the singular values and left and right singular vectors
!     of A (A = U*S*V, m.ge.n)

      Call dgesvj('G', 'U', 'V', m, n, a, lda, s, 0, v, ldv, work, lwork, &
        info)

      If (info==0) Then

!       Compute the approximate error bound for the computed singular values
!       using the 2-norm, s(1) = norm(A), and machine precision, eps.
        eps = epsilon(1.0E0_dp)
        serrbd = eps*s(1)

!       Print solution
        Write (nout, *) 'Singular values'
        Write (nout, 100)(s(j), j=1, n)

        If (abs(work(1)-1.0_dp)>eps) Then
          Write (nout, 130) 'Values need scaling by factor = ', work(1)
        End If
        Flush (nout)

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_real_gen('General', ' ', m, n, a, lda, &
          'Left singular vectors', ifail)

        Write (nout, *)
        Flush (nout)

        ifail = 0
        Call nagf_file_print_matrix_real_gen('General', ' ', n, n, v, ldv, &
          'Right singular vectors', ifail)

!       Call DDISNA to estimate reciprocal condition
!       numbers for the singular vectors
        Call ddisna('Left', m, n, s, rcondu, info)
        Call ddisna('Right', m, n, s, rcondv, info)

!       Print the approximate error bounds for the singular values
!       and vectors
        Write (nout, '(/1X,A)') 'Error estimate for the singular values'
        Write (nout, 110) serrbd
        Write (nout, '(/1X,A)') 'Error estimates for left singular vectors'
        Write (nout, 110)(serrbd/rcondu(i), i=1, n)
        Write (nout, '(/1X,A)') 'Error estimates for right singular vectors'
        Write (nout, 110)(serrbd/rcondv(i), i=1, n)
      Else
        Write (nout, 120) 'Failure in DGESVJ. INFO =', info
      End If

100   Format (3X, (8F8.4))
110   Format (4X, 1P, 6E11.1)
120   Format (1X, A, I4)
130   Format (/, 1X, A, 1P, E13.5)
    End Program


c     # -----------------------------------------------------
c     # GAUSSIAN_SUM
c     #
c     # Computes the value q at a point (x,y,z), where q
c     # is defined by the sum
c     #
c     #             q = sum_{i=1,n} g(x,y,z;xi,yi,zi,a,hmax)
c     #
c     #          g(x,y,z;xi,yi,zi,a,hmax) = hmax*exp(-a*r2)
c     #
c     #          r2 = (x-xi)**2 + (y-yi)**2 + (z-zi)**2
c     #
c     # Note : 'td' means "time dependent"
c     # -----------------------------------------------------

      double precision function gaussian_sum(xp,yp,zp)
      implicit none

      double precision xp, yp, zp

      double precision wc(3,2)
      common /location_parms/ wc

      double precision a, hmax
      common /gaussian_parms/ a, hmax

      integer m, k
      double precision w(3), qv, q
      double precision gaussian_flat, gaussian_sphere
      logical isflat

      q = 0
      do m = 1,2
         do k = 1,3
            w(k) = wc(k,m)
         end do
         if (isflat()) then
            qv = gaussian_flat(xp,yp,zp,w,a,hmax)
         else
            qv = gaussian_sphere(xp,yp,zp,w,a,hmax)
         endif
         q  = q  + qv
      enddo

      gaussian_sum = q

      end

      double precision function gaussian_flat(x,y,z,w,a,hmax)
      implicit none

      double precision x,y,z,w(3),a, r2, hmax

      r2 = (x-w(1))**2 + (y - w(2))**2 + (z - w(3))**2
      gaussian_flat = hmax*exp(-a*r2)

      end

      double precision function gaussian_sphere(x,y,z,w,a,hmax)
      implicit none

      double precision x,y,z,w(3),a,q, hmax

      double precision get_gc_distance, d

      d = get_gc_distance(x,y,z,w)
      q = hmax*exp(-a*d**2)

      gaussian_sphere = q

      end


       FUNCTION distance (lon1, lat1, lon2, lat2)
C****
C               *****************************
C               * OASIS ROUTINE  -  LEVEL ? *
C               * -------------     ------- *
C               *****************************
C
C**** *distance*  - calculate the distance between two points on a sphere
C
C     Purpose:
C     -------
C     Calculation of the distance between two points on a sphere
C       1. Transformation to x,y,z-coordinates
C       2. Calculating the distance
C       3. Calculating the distance on the sphere
C
C**   Interface:
C     ---------
C       *CALL*  *distance*(lon1, lat1, lon2, lat2)
C
C     Input:
C     -----
C          lon1              : longitude of first point (rad)
C          lat1              : latitude of first point (rad)
C          lon2              : longitude of second point (rad)
C          lat2              : latitude of second point (rad)
C
C     Output:
C     ------
C          distance          : distance
CC
C     History:
C     -------
C       Version   Programmer     Date        Description
C       -------   ----------     ----        -----------
C       2.5       V. Gayler      2001/09/20  created
C
C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
      USE constants
      USE kinds_mod

      IMPLICIT NONE
!-----------------------------------------------------------------------
!     INTENT(IN)
!-----------------------------------------------------------------------
      REAL (kind=real_kind), INTENT(IN) ::
     $     lon1,                ! longitude of first point (rad)
     $     lon2,                ! longitude of second point (rad)
     $     lat1,                ! latitude of first point (rad)
     $     lat2                 ! latitude of second point (rad)

!-----------------------------------------------------------------------
!     LOKAL VARIABLES
!-----------------------------------------------------------------------
      REAL (kind=real_kind) ::
     $     x1, y1, z1,          ! coordinates of the first point
     $     x2, y2, z2,          ! coordinates of the second point
     $     distance             ! distance between the points (rad)

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

!     Transformation to x,y,z-coordinates
!     -----------------------------------
      x1 = cos(lat1)*cos(lon1)
      y1 = cos(lat1)*sin(lon1)
      z1 = sin(lat1)

      x2 = cos(lat2)*cos(lon2)
      y2 = cos(lat2)*sin(lon2)
      z2 = sin(lat2)

!     Calculation of the distance
!     ---------------------------
!     direct distance:
      distance = SQRT((x2-x1)**2 + (y2-y1)**2 + (z2-z1)**2)

!     distance along the surface:
      distance = 2*ASIN(distance/2)

!-----------------------------------------------------------------------
      RETURN
      END FUNCTION distance


module CART_COE
! Description:
!    Routines to convert between Cartesian coordinates in the inertial frame
!    and classical orbital elements.
!
! Author:
!    Davide Amato
!    Space Dynamics Group - Technical University of Madrid
!    davideamato@email.arizona.edu
!
! ==============================================================================

use KINDS,      only: dk
use PHYS_CONST, only: pi,twopi,mzero
implicit none

contains

subroutine COE2CART(COE,R,V,GM,tolKE)
! Description:
!    Computes Cartesian state (R,V) from classical orbital elements COE.

! MODULES
use KEPLER, only: KESOLVE

! VARIABLES
implicit none
! Arguments
real(dk),intent(in)           ::  COE(1:6),GM
real(dk),intent(in),optional  ::  tolKE
real(dk),intent(out)          ::  R(1:3),V(1:3)
!logical,intent(out)           ::  KEflag
! Locals
real(dk)  ::  a,e,i,O,w,M,p
real(dk)  ::  EA
real(dk)  ::  sini,cosi,sinO,cosO,sinw,cosw,sinE,cosE,sinf,cosf
real(dk)  ::  R_pf(1:3),V_pf(1:3)
real(dk)  ::  ROT(1:3,1:3)

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

! CLASSICAL ORBITAL ELEMENTS
! N.B: Units of length have to be consistent between COE(1) and GM; COE(2:6) are
! in radians.
!
! COE(1): a, semi-major axis
! COE(2): e, eccentricity
! COE(3): i, inclination
! COE(4): O, right ascension of ascending node
! COE(5): w, argument of periapsis
! COE(6): M, mean anomaly

! Modification (15.01.2016): tolKE is the tolerance for the iterative solver of
! the Kepler equation. If not present, it is set to the machine epsilon

! ==============================================================================================
! 01. UNPACKING OF STATE VECTOR AND CHECK FOR SPECIAL CASES
! ==============================================================================================

a = COE(1); e = COE(2); i = COE(3)
O = COE(4); w = COE(5); M = COE(6)
p = a*(1._dk - e**2)

! Bring M to [-2pi,2pi]
M = mod(M,real(twopi,dk))

! Elliptical, equatorial (assume that 'w' is the true longitude of periapsis)
!if (abs(sin(i)) <= zero) then
!! Circular, inclined (assume that 'nu' is the argument of latitude)
!if (e <= zero) w = 0._dk
!! The case "Circular, equatorial" is covered now, assuming that 'nu' is the true longitude.

sini = sin(i); cosi = cos(i)
sinO = sin(O); cosO = cos(O)
sinw = sin(w); cosw = cos(w)
! Compute true anomaly
if (present(tolKE)) then
    EA = KESOLVE(e,M,tolKE)
else
    EA = KESOLVE(e,M,mzero)
end if
sinE = sin(EA); cosE = cos(EA)
sinf = (sqrt(1._dk - e**2)*sinE)/(1._dk - e*cosE)
cosf = (cosE - e)/(1._dk - e*cosE)

! ==============================================================================
! 02. COMPUTE POS, VEL IN PERifOCAL FRAME
! ==============================================================================

R_pf = p*[cosf/(1._dk+e*cosf), sinf/(1._dk+e*cosf), 0._dk]
V_pf = sqrt(GM/p)*[-sinf, e + cosf, 0._dk]

! ==============================================================================
! 03. COMPUTE ROTATION MATRIX
! ==============================================================================

ROT(1,1) =  cosO*cosw - sinO*sinw*cosi
ROT(2,1) =  sinO*cosw + cosO*sinw*cosi
ROT(3,1) =  sinw*sini

ROT(1,2) = -cosO*sinw - sinO*cosw*cosi
ROT(2,2) = -sinO*sinw + cosO*cosw*cosi
ROT(3,2) =  cosw*sini

ROT(1,3) =  sinO*sini
ROT(2,3) = -cosO*sini
ROT(3,3) =  cosi

! ==============================================================================================
! 04. ROTATE VECTORS TO INERTIAL FRAME
! ==============================================================================================

R = matmul(ROT,R_pf)
V = matmul(ROT,V_pf)

end subroutine COE2CART

subroutine CART2COE(R,V,COE,mu)
! Description:
!    Computes classical orbital elements COE from Cartesian coordinates R_in,V_in.
!    Units have to be consistent.
!
! ==============================================================================

! VARIABLES
implicit none
! Arguments
real(dk),intent(in)   ::  R(1:3),V(1:3)
real(dk),intent(in)   ::  mu
real(dk),intent(out)  ::  COE(1:6)
! Locals
real(dk)              ::  p,a,e             ! Orbital elements
real(dk)              ::  inc,RAAN,AoP,nu,M ! Orbital elements
real(dk)              ::  En                ! Total energy
real(dk)              ::  h(1:3),n(1:3)     ! Angular momentum and nodal vector
real(dk)              ::  ecc(1:3)          ! Eccentricity vector
real(dk)              ::  sinn,cosn
real(dk)              ::  EA,sinE,cosE
real(dk)              ::  GA                ! Gudermannian anomaly
real(dk)              ::  rmag,nmag,hmag
real(dk)              ::  zero

! ==============================================================================
!
!                                            EXECUTION
!
! ==============================================================================

! CLASSICAL ORBITAL ELEMENTS
! COE(1): a,  semi-major axis
! COE(2): e,  eccentricity
! COE(3): i,  inclination
! COE(4): Om, right ascension of ascending node
! COE(5): w,  argument of periapsis OR longitude of periapsis
! COE(6): M,  mean anomaly

! =============================================================================
! 02. COMPUTE p,a,ecc,e
! =============================================================================
zero = 2._dk*mzero

rmag   = sqrt(dot_product(R,R))

h(:)   = CROSS_PRODUCT(R,V)
n(:)   = CROSS_PRODUCT([0._dk,0._dk,1._dk],h)
ecc(:) = ((DOT_PRODUCT(V,V) - mu/rmag)*R - DOT_PRODUCT(R,V)*V)/mu
e      = sqrt(dot_product(ecc,ecc))

nmag   = sqrt(dot_product(n,n))

En     = 0.5_dk*DOT_PRODUCT(V,V) - mu/rmag

if (ABS(En) > zero) then
    a  = -mu/(2._dk*En)
    p  = a*(1._dk-e**2)

else ! Exactly parabolic orbit, should be extremely rare
    a  = HUGE(0._dk)
    p  = DOT_PRODUCT(h,h)/mu

end if

! =============================================================================
! 03. COMPUTE inc,RAAN,AoP,nu
! =============================================================================

hmag = sqrt(dot_product(h,h))
inc  = acos(h(3)/hmag)
RAAN = ACOS(n(1)/nmag); if (n(2) < 0._dk) RAAN = twopi - RAAN
AoP  = ACOS(DOT_PRODUCT(n,ecc)/(nmag*e)); if (ecc(3) < 0._dk) AoP  = twopi - AoP

nu   = ACOS(DOT_PRODUCT(ecc,R)/e/rmag)
if (DOT_PRODUCT(R,V) < 0._dk) then
    nu   = twopi - nu

end if

! SPECIAL CASES:
! Elliptical, equatorial. AoP = true longitude of periapsis
if (ABS(ABS(h(3)/hmag)-1._dk) < zero) then
    RAAN = 0._dk
    AoP  = ACOS(ecc(1)/e); if (ecc(2) < 0._dk) AoP = twopi - AoP
end if
! Circular, inclined.   nu = argument of latitude
if (e <= zero) then
    AoP = 0._dk
    nu  = ACOS(DOT_PRODUCT(n,R)/nmag/rmag); if (r(3) < 0._dk) nu = twopi - nu
    M = nu
end if
! Circular, equatorial. nu = true longitude.
if (ABS(ABS(h(3)/hmag)-1._dk) < zero .AND. e <= zero) then
    RAAN = 0._dk
    AoP  = 0._dk
    nu   = ACOS(R(1)/rmag); if (r(2) < 0._dk) nu = twopi - nu
end if

! Mean anomaly (see Battin, Ch. 4)
sinn = sin(nu); cosn = cos(nu)
if (e < 1._dk) then
  sinE = (sinn*sqrt(1._dk - e**2))/(1._dk + e*cosn)
  cosE = (e + cosn)/(1._dk + e*cosn)
  EA = atan2(sinE,cosE)
  M = EA - e*sinE

else if (e > 1._dk) then
  GA = 2._dk * atan( sqrt( (e - 1._dk) / (e + 1._dk) ) * tan(0.5_dk * nu) )
  M = e * tan(GA) - log( tan( 0.5_dk * GA + 0.25_dk * pi ))

end if

! Wrap M to [0,360]
M = mod(M + twopi,twopi)

COE = [a,e,inc,RAAN,AoP,M]

contains

function CROSS_PRODUCT(a,b)
! Description:
!    Computes cross product of a*b.
! ==============================================================================
!                                            PREAMBLE
! ==============================================================================

! VARIABLES
implicit none
! Function definition
real(dk)            :: CROSS_PRODUCT(1:3)
! Arguments
real(dk)            :: a(1:3),b(1:3)

! ==============================================================================
!                                            EXECUTION
! ==============================================================================
CROSS_PRODUCT(1) = a(2)*b(3) - a(3)*b(2)
CROSS_PRODUCT(2) = a(3)*b(1) - a(1)*b(3)
CROSS_PRODUCT(3) = a(1)*b(2) - a(2)*b(1)
end function CROSS_PRODUCT

end subroutine CART2COE

end module CART_COE


*       Home work #1

*       Question (2)
*       Write a FORTRAN program which computes the roots of
*       the following quadratic equation for a given set of
*       coeffficiants A,B.C. (D= b^2-4*a*c is not negative)
*       ax^2+b*x+c=0.

10      print *, ' a*x^2+b*x+c=0'
        Print *, ' enter the value of a,b,c'
        read(*,*) a,b,c
        if(b*b-4*a*c .lt.0) goto 10
        x1=(-b+ sqrt(b*b-4*a*c))/(2*a)
        x2=(-b- sqrt(b*b-4*a*c))/(2*a)

        print*, 'the root of the equation is '

        print*, x1,x2

        stop
        end


program main
    use mpi
    implicit none
    real(8), parameter :: pi = acos(-1.d0), kB = 1.d0
    integer :: ntasks, id, rc
    integer, allocatable :: status(:)
    integer :: i, n, clock
    integer, allocatable :: seed(:)
    real(8) :: r

    real(8) :: T = 1.d0, dT = .01d0, T_final = 5.d0, beta
    integer, parameter :: L_x = 32, L_y = 32
    integer :: lattice(0:L_x - 1,0:L_y - 1) = 1
    integer :: x, y
    integer, parameter :: n_warmup = 10000, n_evol = 100000
    real(8) :: J = 1.d0, B = 0.d0
    real(8) :: M, M_sqr, E_tmp, E, E_sqr, M_ave, M_sqr_ave, chi, E_ave, E_sqr_ave, C

    ! initialize MPI environment
    call MPI_INIT(rc)
    call MPI_COMM_SIZE(MPI_COMM_WORLD, ntasks, rc)
    call MPI_COMM_RANK(MPI_COMM_WORLD, id, rc)
    allocate(status(MPI_STATUS_SIZE))

    ! initialize seeds for different processes
    if (id == 0) then
        call SYSTEM_CLOCK(clock)
        call RANDOM_SEED(size = n)
        allocate(seed(n))
        do i = 1, n
            seed(i) = clock + 37 * i
        end do
        call RANDOM_SEED(PUT = seed)
        deallocate(seed)
        do i = 1, ntasks - 1
            call RANDOM_NUMBER(r)
            clock = clock + Int(r * 1000000)
            call MPI_SEND(clock, 1, MPI_INTEGER, i, i, MPI_COMM_WORLD, rc)
        end do
    else
        call MPI_RECV(clock, 1, MPI_INTEGER, 0, id, MPI_COMM_WORLD, status, rc)
        call RANDOM_SEED(size = n)
        allocate(seed(n))
        do i = 1, n
            seed(i) = clock + 37 * i
        end do
        call RANDOM_SEED(PUT = seed)
        deallocate(seed)
    end if

    if (id == 0) then
        open(unit = 1, file = 'data.txt', status = 'unknown')
        write(*,'(4a15)') 'T', 'M / M_max', 'chi', 'C'
    end if

    do while (T < T_final)
    ! warm up
    beta = 1.d0 / kB / T
    do i = 1, n_warmup
        call EVOLUTION(lattice, L_x, L_y, beta, B, J)
    end do

    if (id == 0) then
        open(unit = 2, file = 'lattice-mpi.txt', status = 'unknown')
        do x = 0, L_x - 1
            do y = 0, L_y - 1
                write(2,'(3i4)') x, y, lattice(x,y)
            end do
        end do
        close(2)
    end if

    ! do while (T < T_final)
        ! beta = 1.d0 / kB / T
        M = 0.d0
        M_sqr = 0.d0
        E = 0.d0
        E_sqr = 0.d0

        ! evolution
        do i = 1, n_evol
            call EVOLUTION(lattice, L_x, L_y, beta, B, J)
            M = M + abs(sum(lattice))
            M_sqr = M_sqr + sum(lattice)**2
            E_tmp = 0.d0
            do x = 0, L_x - 2
                do y = 0, L_y - 2
                    E_tmp = E_tmp + lattice(x, y) * (lattice(x + 1, y) + lattice(x, y + 1))
                end do
            end do
            do x = 0, L_x - 2
                E_tmp = E_tmp + lattice(x, L_y - 1) * (lattice(x + 1, L_y - 1) + lattice(x, 0))
            end do
            do y = 0, L_y - 2
                E_tmp = E_tmp + lattice(L_x - 1, y) * (lattice(L_x - 1, y + 1) + lattice(0, y))
            end do
            E_tmp = E_tmp + lattice(L_x - 1, L_y - 1) * (lattice(0, L_y - 1) + Lattice(L_x - 1, 0))
            E_tmp = - E_tmp * J - B * sum(lattice)
            E = E + E_tmp
            E_sqr = E_sqr + E_tmp**2
        end do
        call MPI_REDUCE(M, M_ave, 1, MPI_REAL8, MPI_SUM, 0, MPI_COMM_WORLD, rc)
        call MPI_REDUCE(M_sqr, M_sqr_ave, 1, MPI_REAL8, MPI_SUM, 0, MPI_COMM_WORLD, rc)
        call MPI_REDUCE(E, E_ave, 1, MPI_REAL8, MPI_SUM, 0, MPI_COMM_WORLD, rc)
        call MPI_REDUCE(E_sqr, E_sqr_ave, 1, MPI_REAL8, MPI_SUM, 0, MPI_COMM_WORLD, rc)
        if (id == 0) then
            M_ave = M_ave / dble(ntasks * n_evol)
            M_sqr_ave = M_sqr_ave / dble(ntasks * n_evol)
            chi = beta * (M_sqr_ave - M_ave**2)
            E_ave = E_ave / dble(ntasks * n_evol)
            E_sqr_ave = E_sqr_ave / dble(ntasks * n_evol)
            C = kB * beta**2 / dble((L_x) * (L_y)) * (E_sqr_ave - E_ave**2)
            write(*,'(4f15.5)') T, M_ave / dble(L_x * L_y), chi, C
            write(1,'(4f15.5)') T, M_ave / dble(L_x * L_y), chi, C
        end if
        T = T + dT
    end do

    if (id == 0) then
        close(1)
    end if

    ! done with MPI
    call MPI_FINALIZE(rc)
end program main

subroutine EVOLUTION(lattice, L_x, L_y, beta, B, J)
    implicit none
    integer, intent(in) :: L_x, L_y
    integer, intent(inout) :: lattice(0:L_x - 1, 0:L_y - 1)
    real(8), intent(in) :: beta, B, J
    real(8) :: r
    integer :: x, y
    real(8) :: dE

    call RANDOM_NUMBER(r)
    x = floor(r * dble(L_x))
    call RANDOM_NUMBER(r)
    y = floor(r * dble(L_y))

    dE = 0.d0
    dE = dE + 2.d0 * J * lattice(x,y) * (lattice(modulo(x - 1, L_x), y)&
        + lattice(modulo(x + 1, L_x), y)&
        + lattice(x, modulo(y - 1, L_y))&
        + lattice(x, modulo(y + 1, L_y)))&
        + 2.d0 * B * dble(lattice(x,y))

    call RANDOM_NUMBER(r)
    if (r <= exp(-beta * dE)) then
        lattice(x,y) = -lattice(x,y)
    end if
end subroutine EVOLUTION


!======================================================================!
  SUBROUTINE CalcShear(Ui, Vi, Wi, She)
!----------------------------------------------------------------------!
!  Computes the magnitude of the shear stress.                         !
!----------------------------------------------------------------------!
!  She = sqrt( 2 * Sij * Sij )                                       !
!  Sij = 1/2 ( dUi/dXj + dUj/dXi )                                     !
!----------------------------------------------------------------------!
!------------------------------[Modules]-------------------------------!
  USE all_mod
  USE pro_mod
  USE les_mod
  USE rans_mod
!----------------------------------------------------------------------!
  IMPLICIT NONE
!-----------------------------[Parameters]-----------------------------!
  REAL          :: Ui(-NbC:NC), Vi(-NbC:NC), Wi(-NbC:NC)
  REAL          :: She(-NbC:NC)
!-------------------------------[Locals]-------------------------------!
  INTEGER :: c
!--------------------------------[CVS]---------------------------------!
!  $Id: CalcShear.f90,v 1.9 2008/11/19 14:51:08 IUS\mhadziabdic Exp $
!  $Source: /home/IUS/mhadziabdic/.CVSROOT/T-Rex/Process/CalcShear.f90,v $
!======================================================================!

  call Exchng(Ui)
  call Exchng(Vi)
  call Exchng(Wi)

!===================!
!                   !
!     SGS terms     !
!                   !
!===================!
  call GraPhi(Ui,1,Ux, .TRUE.)  ! dU/dx
  call GraPhi(Ui,2,Uy, .TRUE.)  ! dU/dy
  call GraPhi(Ui,3,Uz, .TRUE.)  ! dU/dz
  call GraPhi(Vi,1,Vx, .TRUE.)  ! dV/dx
  call GraPhi(Vi,2,Vy, .TRUE.)  ! dV/dy
  call GraPhi(Vi,3,Vz, .TRUE.)  ! dV/dz
  call GraPhi(Wi,1,Wx, .TRUE.)  ! dW/dx
  call GraPhi(Wi,2,Wy, .TRUE.)  ! dW/dy
  call GraPhi(Wi,3,Wz, .TRUE.)  ! dW/dz

  do c=1,NC
    She(c) = Ux(c)*Ux(c) + Vy(c)*Vy(c) + Wz(c)*Wz(c) + &
                 0.5*(Vz(c) + Wy(c))*(Vz(c) + Wy(c)) + &
                 0.5*(Uz(c) + Wx(c))*(Uz(c) + Wx(c)) + &
                 0.5*(Vx(c) + Uy(c))*(Vx(c) + Uy(c))

     Vort(c) =  -(0.5*(Vz(c) - Wy(c))*(Vz(c) - Wy(c)) + &
                  0.5*(Uz(c) - Wx(c))*(Uz(c) - Wx(c)) + &
                  0.5*(Vx(c) - Uy(c))*(Vx(c) - Uy(c)))

  end do

  She = sqrt(2.0 * She)
  Vort = sqrt(2.0*abs(Vort))

  END SUBROUTINE CalcShear


( Test Machine Code Compilation )
( This program should be compiled with --mcode and --optimize options. )

[hex] 2400 const SCREEN
[hex] 3C37 const STKBOT
[hex] 3C3B const SPARE

100 variable v
500 variable temp

( Define some words which return numbers which won't be optimized as literals. )
: one 0 1+ ;
: two 0 2+ ;
: three 0 2+ 1+ ;
: minus-one 0 1- ;
: minus-two 0 2- ;
: minus-three 0 2- 1- ;

: fail ." FAILED!" abort ;

: chk ( result expected -- )
	= if ." OK" else fail then ;

: chk2 ( result1 result2 expected1 expected2 -- )
	rot = >r ( s: result1 expected1 ; r: eq2 )
	= r> ( s: eq1 eq2 )
	and if ." OK" else fail then ;

: chk3 ( result1 result2 result3 expected1 expected2 expected3 -- )
	4 roll = >r ( s: result1 result2 expected1 expected2 ; r: eq3 )
	3 roll = >r ( s: result1 expected1 ; r: eq3 eq2 )
	= r> r> ( s: eq1 eq2 eq3 )
	and and if ." OK" else fail then ;

: stack
	." DUP    " 123 dup          123 123 chk2 cr
	." DROP   " 123 456 drop     123 chk cr
	." NIP    " 1 2 3 nip        1 3 chk2 cr
	." OVER   " 123 456 over     123 456 123 chk3 cr
	." ?DUP   " 123 ?dup         123 123 chk2 space
	            123 0 ?dup 456   123 0 456 chk3 cr
	." SWAP   " 123 456 swap     456 123 chk2 cr
	." 2DUP   " 123 456 2dup     123 456 chk2 space 123 456 chk2 cr
	." 2DROP  " 1 2 3 2drop      1 chk cr
	." 2OVER  " 1 2 3 4 2over    1 2 chk2 3 4 space chk2 space 1 2 chk2 cr
	." PICK   " 3 4 2 pick       3 4 3 chk3 cr
	." ROLL   " 1 2 2 roll       2 1 chk2 space
	            1 2 3 3 roll     2 3 1 chk3 cr
	." ROT    " 1 2 3 rot        2 3 1 chk3 cr
	." >R R>  " 3 7 >r           3 chk space r> 7 chk cr
	." R@     " 1 2 >r r@        1 2 chk2 cr    ( Clean up: ) r> drop
	;

: arith
	." +      " 3 4 +                7 chk space      ( n + literal )
	            -1000 -2000 +        -3000 chk space
	            500 v @ +            600 chk space    ( n + n )
	            [ hex ] 134 5000 +   5134 chk cr [ decimal ]

	." -      " 3 4 -                -1 chk space     ( n - literal )
	            -1000 -2000 -        1000 chk space
	            500 v @ -            400 chk space    ( n - n )
	            [ hex ] 5134 5000 -  134 chk cr [ decimal ]

	." *      " 1000 5 *         5000 chk space   ( n * literal )
	            -123 5 *         -615 chk space
	            -123 0 *         0 chk space      ( 0* )
	            -123 1 *         -123 chk space   ( 1* )
	            -123 2 *         -246 chk space   ( 2* )
	            -123 4 *         -492 chk space   ( 4* )
	            -123 256 *       -31488 chk space ( 256* )
	            -12 512 *        -6144 chk space  ( 512* )
	            -12 2048 *       -24576 chk space ( 512* )
	            -1 32768 *       -32768 chk space ( 32768* )
	            100 v @ *        10000 chk cr     ( n * n )

	." C*     " 5 50 c*          250 chk space    ( n * literal )
	            2 v @ c*         200 chk space    ( n * value )
	            3 1 c*           3 chk space      ( 1 specialization )
	            3 2 c*           6 chk space      ( 2 specialization )
	            3 4 c*           12 chk space     ( 4 specialization )
	            240 120 c*       28800 chk space
	            120 240 c*       28800 chk space
	            3 256 c*         0 chk cr         ( out of range specialization )

	." /      " 1000 3 /         333 chk space    ( Generic algorithm )
                1000 1 /         1000 chk space   ( 1/ )
                1000 2 /         500 chk space    ( 2/ )
                1000 4 /         250 chk space    ( 4/ )
                -1000 8 /        -125 chk space   ( 8/ )
                1000 256 /       3 chk space      ( 256/ )
                10000 1024 /     9 chk cr

	." 1+     " 5 1+             6 chk cr

	." 1-     " 5 1-             4 chk cr

	." 2+     " 1000 2+          1002 chk cr

	." 2-     " 1000 2-          998 chk cr

	." 2*     " 1000 2*          2000 chk space
	            -1000 2*         -2000 chk cr

	." 2/     " 1000 2/          500 chk space
	            -1000 2/         -500 chk cr

	." NEGATE " 1234 negate      -1234 chk space
	            -1234 negate     1234 chk cr

	." ABS    " 4892 abs         4892 chk space
	            -4892 abs        4892 chk cr

	." MIN    " 7000 123 min     123 chk space
	            -7000 123 min    -7000 chk cr

	." MAX    " 7000 123 max     7000 chk space
	           -7000 123 max     123 chk cr

	[ hex ]
 	." XOR    " 1234 1111 xor    0325 chk space   ( n xor literal )
 				1fff v @ xor	 1f9b chk space   ( n xor n )
 				1234 0 xor       1234 chk space   ( 0 specialization )
 				1234 11 xor	     1225 chk space   ( lo byte only )
 				1234 1100 xor	 0334 chk cr      ( hi byte only )

 	." AND    " 7777 1f1f and    1717 chk space   ( n and literal )
 	            0ff0 v @ and     60 chk space     ( n and n )
 	            ffff 11 and      11 chk space     ( lo byte only )
 	            ffff fa00 and    fa00 chk space   ( hi byte only )
 	            1234 ff and      34 chk space     ( select lo byte )
 	            1234 ff00 and    1200 chk cr      ( select hi byte )

 	." OR     " 1234 f0f0 or     f2f4 chk space   ( n or literal )
 	            f0 v @ or        f4 chk space     ( n or n )
 	            1234 ff or       12ff chk space   ( set lo byte )
 	            1234 ff00 or     ff34 chk cr      ( set hi byte )
 	[ decimal ]
	;

: rel-ops
	." 0=     " 0 0=             1 chk space
	            256 0=           0 chk cr

	." 0<     " -5000 0<         1 chk space
	            0 0<             0 chk space
	            5000 0<          0 chk cr

	." 0>     " 5000 0>          1 chk space
	            0 0>             0 chk space
	            -5000 0>         0 chk cr

	." =      " 3 5 =            0 chk space
	            12345 12345 =    1 chk space
	            -12345 12345 =   0 chk space
	            100 v @ =        1 chk space    ( Non-literal )
	            101 v @ =        0 chk cr       ( Non-literal )

	." C=     " 3 5 c=           0 chk space
	            50 50 c=         1 chk space
	            1024 0 c=        1 chk space	( Only hi bytes differ )
	            -50 50 c=        0 chk space
	            100 v c@ c=      1 chk space    ( Non-literal )
	            101 v c@ c=      0 chk cr       ( Non-literal )

	." C>     " 3 5 c>           0 chk space
				5 5 c>           0 chk space
				6 5 c>           1 chk space
				255 50 c>        1 chk space
				255 255 c>       0 chk space
				0 -1 c>          0 chk space
				1 three c>       0 chk space
				4 three c>       1 chk space
				3 three c>       0 chk space
				-1 three c>      1 chk cr       ( Comparison is unsigned, so -1 equals 255 )

	." C<     " 3 5 c<           1 chk space
				5 5 c<           0 chk space
				6 5 c<           0 chk space
				30 0 c<          0 chk space
				254 -1 c<        1 chk space
				1 three c<       1 chk space
				4 three c<       0 chk space
				3 three c<       0 chk cr

	." >      " 3000 5000 >      0 chk space
	            5000 -3000 >     1 chk space
	            -3000 5000 >     0 chk space
	            -1000 -2000 >    1 chk space
	            -2000 -1000 >    0 chk space
	            1000 1000 >      0 chk space
	            -1000 -1000 >    0 chk space
	            0 0 >            0 chk cr

	." <      " 3000 5000 <      1 chk space
	            5000 -3000 <     0 chk space
	            -3000 5000 <     1 chk space
	            -1000 -2000 <    0 chk space
	            -2000 -1000 <    1 chk space
	            1000 1000 <      0 chk space
	            -1000 -1000 <    0 chk space
	            0 0 <            0 chk cr
	;

: mem
	." ! @    " 12345 v ! v @       12345 chk space ( Literal address )
	            v 12345 over ! @    12345 chk cr    ( Non-literal address )

	." C! C@  " 123 v c! v c@       123 chk space   ( Literal address )
	            v 123 over c! c@    123 chk cr      ( Non-literal address )

	." INC    " temp inc temp @     501 chk cr

	." DEC    " temp dec temp @     500 chk cr
	;

: test-again
	1
	begin
		dup +
		dup 1000 > if exit then
	again ;

: test-loop
	0
	2 0 do
		5 0 do
			i j + +
		loop
	loop ;

: test-leave
	0
	100 0 do
		1+
		i 10 = if leave then
	loop ;

: test-goto
	123 >r
	3
	label back
		r> 1- >r
		1-
	?dup if goto back then
	r> ;

: control-flow
	." IF     " 1 2 if 3 then                  1 3 chk2 space
	            1 0 if 2 else 3 then           1 3 chk2 cr

	." UNTIL  " 6 1 0 0 begin 5 >r until       r> r> r> 5 5 5 chk3 space 6 chk cr

	." AGAIN  " test-again                     1024 chk cr

	." LOOP   " 0 1000 -100 do i + loop        -29838 chk space ( 16-bit )
				0 100 0 do i + loop            4950 chk space ( 8-bit )
	            0 three one do i + loop        3 chk space ( Non-literal counter & limit )
				0 10 20 do i + loop            20 chk space ( "Invalid loop" )
	            test-loop                      25 chk space
	            test-leave                     11 chk cr

	." +LOOP  " 0 500 -300 do i + 2 +loop      -25936 chk space ( Count up )
	            0 -300 500 do i + -3 +loop     26967 chk space ( Count down )
	            0 500 -300 do i + two +loop    -25936 chk space ( Generic, count up )
	            0 -300 500 do i + minus-three +loop     26967 chk cr ( Generic, count down )

	." I'     " 0 10 0 do i' + loop            100 chk cr

	." GOTO   " 5 goto skip 6 label skip       5 chk space ( Forward goto )
	            test-goto                      120 chk cr ( Backward goto )
	;

: print
	." EMIT   " ascii * emit cr
	." SPACE  " space ascii * emit cr
	." SPACES "	2 spaces ascii * emit cr
	( 0 29 at ." AT" )
	." TYPE   " 15424 5 type space ." RULES" cr
	;

: test-in-out
	." PLAYING SOUND..."
	12345
	100 begin
		65278 in drop ( pull speaker )
		300 0 do loop
		0 65278 out ( push speaker )
		300 0 do loop
		1- dup 0=
	until drop ;

: test-inkey
	." *PRESS SPACE* "
	begin
		inkey 32 =
	until ;

: double 2* ;
:m test-macro 1 100 + postpone lit   postpone double ;

: misc
	." LIT    " [ 5 3 * ] lit      15 chk cr
	." CONST  " SCREEN             9216 chk cr
	." MACRO  " test-macro         202 chk cr

	." BASE   " 8 base c! 255 . cr ( ff )
	." HEX    " hex 255 . cr ( ff )
	." DEC    " decimal 255 . cr ( 255 )
	." .S     " 1 2 3 .s drop drop drop cr
	;

: i/o
	." INKEY  " test-inkey cr
	." IN OUT " test-in-out cr    12345 chk cr
	;

: benchmark-stack
	10000 0 do
		dup dup dup dup dup dup dup dup dup dup
		drop drop drop drop drop drop drop drop drop drop
	loop ;

: benchmark-over
	100 0 do
		over over over over over over over over over over
		over over over over over over over over over over
		over over over over over over over over over over
		over over over over over over over over over over
		over over over over over over over over over over
		STKBOT @ 14 + SPARE ! ( Reset stack, except profile start time )
	loop ;

: benchmark-swap
	1 2
	10000 0 do
		swap swap swap swap swap swap swap swap swap swap
	loop 2drop ;

: benchmark-loop
	200 0 do
		200 0 do loop
	loop ;

: benchmark-rstack
	5000 0 do
		>r r> >r r> >r r> >r r> >r r> >r r> >r r> >r r>
		>r r> >r r> >r r> >r r> >r r> >r r> >r r> >r r>
	loop ;

: benchmark-arith
	5
	10000 0 do
		dup + dup + dup + dup + dup - dup - dup - dup -
	loop drop ;

: benchmark-arith2
	5
	10000 0 do
		1 + 2 + 3 + 4 + 5 +
		1 - 2 - 3 - 4 - 5 -
	loop drop ;

: benchmark-1+
	0
	10000 0 do
		1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+
	loop drop ;

: benchmark-2*
	5000 0 do
		3 2* 2* 2* 2* 2* 2* 2* 2* 2* drop
	loop ;

: benchmark-2/
	500 0 do
		31111 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ drop
	loop ;

: benchmark-*
	2
	1000 0 do
		2 * 7 * 123 * 256 * 789 *
	loop drop ;

: benchmark-c*
	2
	1000 0 do
		2 c* 5 c* 9 c* 10 c* 7 c*
	loop drop ;

: time ( -- time )
	252 in ( lo byte )
	253 in ( hi byte )
	256 * + ;

: begin-profile ( -- start-time ) time ;

: end-profile ( start-time -- ) time swap - . cr ;

: main
	fast di cls invis
	stack
	arith
	rel-ops
	mem
	control-flow
	print
	misc

	cr ." Running benchmarks..." cr
	." STACK  " begin-profile benchmark-stack end-profile 	    ( 17830 -> 5680, 3.1 times faster )
	." OVER   " begin-profile benchmark-over end-profile		( 2257 -> 204, 11 times faster )
	." SWAP   " begin-profile benchmark-swap end-profile		( 15091 -> 3865, 3.9 times faster )
	." LOOP   " begin-profile benchmark-loop end-profile		( 4676 -> 598, 7.8 times faster )
	." >R R>  " begin-profile benchmark-rstack end-profile 	    ( 11088 -> 5000, 2.2 times faster )
	." ARITH  " begin-profile benchmark-arith end-profile	    ( 24795 -> 5151, 4.8 times faster )
	." ARITH2 " begin-profile benchmark-arith2 end-profile	    ( 27322 -> 751, 36 times faster )
	." 1+     " begin-profile benchmark-1+ end-profile		    ( 12266 -> 425, 29 times faster )
	." 2*     " begin-profile benchmark-2* end-profile		    ( 14256 -> 613, 23 times faster )
	." 2/     " begin-profile benchmark-2/ end-profile		    ( 19159 -> 62, 309 times faster )
	." *      " begin-profile benchmark-* end-profile		    ( 3435 -> 1232, 2.8 times faster )
	." C*     " begin-profile benchmark-c* end-profile		    ( 3689 -> 523, 7.1 times faster )

	cr i/o

	cr ." All tests passed!"
	;