c
c program mapiso
c
      include 'VICMAIN_FOR'
      subroutine main44
      include 'mp_for_defs'

      integer*2 obuf(1002,502)
      integer*4 ounit,def,count
      integer*4 status,nl,ns,samp
      real*8 mp
      integer*4 idata(40)
      real*4 data(40)
      real*8 a,b,r2d,d2r,x,y,t,x_center,y_center
      equivalence (data,idata)

c parameters
      call xvparm('NL',nl,count,def,1)
      call xvparm('NS',ns,count,def,1)
      a=(ns-2)/2.d0
      b=(nl-2)/2.d0
      r2d=45.d0/datan(1.d0)
      d2r=1.d0/r2d
      x_center=ns/2.0
      y_center=nl/2.0

c open output
      call xvunit(ounit,'OUT',1,status,' ')
      call xvsignal(ounit,status,1)
      call xvopen(ounit,status,'U_FORMAT','HALF',
     +        'U_NL',nl,'U_NS',ns,'OP','WRITE',
     +        'O_FORMAT','BYTE',' ')
      call xvsignal(ounit,status,1)

c initialize mp routines
      call mp_init( mp,istat)
      if(istat.ne.mp_success) call mabend('error in mp_init')
c write mp label
      data(25)=b         !r pole in km
      data(26)=a         !r equator in km
      data(31)=0.0       !sclat
      data(32)=0.0       !sclon
      data(33)=y_center  !centline
      data(34)=x_center  !centsamp
      data(38)=1000.*b   !range in km
      data(27)=1000.*b   !focal in pixels or mm
      data(30)=1.0       !scale
      data(35)=0.0       !north
      data(28)=y_center  !oaline
      data(29)=x_center  !oasamp
      idata(39)=16       ! perspective type
      call mp_buf2mpo( idata, mp, status )
      if ( status .ne. 0 ) then
          call xvmessage ('MP error on buffer transfer',0)
          return
      end if
      call mp_label_write( mp, ounit, 'HISTORY', status )
      if ( status .ne. 0 ) then
          call xvmessage ('MP label write error',0)
          return
      end if
      call mp_label_write( mp, ounit, 'PROPERTY', status )
      if ( status .ne. 0 ) then
          call xvmessage ('MP label write error',0)
          return
      end if

c process image

c set background.
      do line=1,nl                         ! line loop
        do samp=1,ns                          ! pixel loop
          obuf(samp,line)=1
        enddo
      enddo

c draw limb.
      dangle=(1.d0/a)*r2d
      do angle=0,89.999,dangle
        t=tan(angle*d2r)
        x=a*b*dsqrt(1.d0/(b*b+a*a*t*t))
        y=x*t
        i=nint(x + x_center)
        j=nint(y + y_center)
        if((i.ge.1).and.(i.le.ns).and.(j.ge.1).and.(j.le.nl))
     +    obuf(i,j)=255
        i=nint(-x + x_center)
        j=nint(y + y_center)
        if((i.ge.1).and.(i.le.ns).and.(j.ge.1).and.(j.le.nl))
     +    obuf(i,j)=255
        i=nint(x + x_center)
        j=nint(-y + y_center)
        if((i.ge.1).and.(i.le.ns).and.(j.ge.1).and.(j.le.nl))
     +    obuf(i,j)=255
        i=nint(-x + x_center)
        j=nint(-y + y_center)
        if((i.ge.1).and.(i.le.ns).and.(j.ge.1).and.(j.le.nl))
     +    obuf(i,j)=255
      enddo

c draw latitudes.
      dangle=10.
      do angle=0,89.999,dangle
        t=tan(angle*d2r)
        x=a*b*dsqrt(1.d0/(b*b+a*a*t*t))
        y=x*t
        i1=nint(-x + x_center)
        i2=nint(x + x_center)
        j1=nint(-y + y_center)
        j2=nint(y + y_center)
        if(i1.lt.1)i1=1
        if(i2.gt.ns)i2=ns
        if(j1.ge.1.and.j1.le.nl)then
          do i=i1,i2
            obuf(i,j1)=255
          enddo
        endif
        if(j2.ge.1.and.j2.le.nl)then
          do i=i1,i2
            obuf(i,j2)=255
          enddo
        endif
      enddo

c write image
      do line=1,nl                         ! line loop
        call xvwrit(ounit,obuf(1,line),status,' ')
        call xvsignal(ounit,status,1)
      enddo

      return
      end


!
! Spectral_Units_Conversion
!
! Module containing functions to convert between various spectral units.
!
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 14-Jan-2002
!                       paul.vandelst@noaa.gov
!
!

MODULE Spectral_Units_Conversion

  ! -----------------
  ! Environment setup
  ! -----------------
  ! Module use
  USE Type_Kinds,            ONLY: fp
  USE Fundamental_Constants, ONLY: C => SPEED_OF_LIGHT
  ! Disable implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  PRIVATE
  PUBLIC :: GHz_to_inverse_cm
  PUBLIC :: inverse_cm_to_GHz
  PUBLIC :: micron_to_inverse_cm
  PUBLIC :: inverse_cm_to_micron

  ! -----------------
  ! Module parameters
  ! -----------------
  ! Version Id for the module
  CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = &
  '$Id$'
  REAL(fp), PARAMETER :: ZERO = 0.0_fp
  REAL(fp), PARAMETER :: ONE  = 1.0_fp

CONTAINS

!------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       GHz_to_inverse_cm
!
! PURPOSE:
!       Function to convert frequencies in units of gigahertz (GHz) to units
!       of inverse centimetres (cm^-1)
!
! CALLING SEQUENCE:
!       Wavenumber = GHz_to_inverse_cm( Frequency )
!
! INPUTS:
!       Frequency:      Frequency in gigahertz. Must be > 0.0
!                       UNITS:      GHz
!                       TYPE:       REAL(fp)
!                       DIMENSION:  Scalar or any rank array
!                       ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
!       Wavenumber:     The frequency in inverse centimetres.
!                       Value is 0.0 for an input frequency < or = 0.0.
!                       UNITS:      cm^-1
!                       TYPE:       REAL(fp)
!                       DIMENSION:  Same as input argument.
!
! PROCEDURE:
!       The relationship between wavelength and frequency is given by,
!
!              c
!         l = ---  metres     .....(1)
!              f
!
!       where c = speed of light in m.s^-1
!             f = frequency in Hz (s^-1).
!
!       The conversion of wavelength, l, to frequency, v, in cm^-1, is given by,
!
!                1
!         v = -------  cm^-1     .....(2)
!              100 l
!
!       where the factor of 100 converts l from metres to centimetres.
!       Substituting (2) into (1) gives,
!
!               f
!         v = -------  cm^-1     .....(3)
!              100 c
!
!       If f is expressed as gigahertz, then (3) becomes,
!
!              10^9 f
!         v = -------- cm^-1
!              100  c
!
!                   f
!           = 10^7 --- cm^-1
!                   c
!
!       Therefore the conversion factor from GHz to inverse centimeters is
!       10^7/c where c is in m.s^-1.
!
!:sdoc-:
!------------------------------------------------------------------------------

  ELEMENTAL FUNCTION GHz_to_inverse_cm( Frequency ) RESULT( Wavenumber )
    REAL(fp), INTENT(IN) :: Frequency
    REAL(fp)             :: Wavenumber
    REAL(fp), PARAMETER  :: SCALE_FACTOR = 1.0e+07_fp
    IF ( Frequency < EPSILON(ONE) ) THEN
      Wavenumber = ZERO
      RETURN
    END IF
    Wavenumber = SCALE_FACTOR * Frequency / C
  END FUNCTION GHz_to_inverse_cm

!------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       inverse_cm_to_GHz
!
! PURPOSE:
!       Function to convert frequencies in units of inverse centimetres (cm^-1)
!       to units of gigahertz (GHz)
!
! CALLING SEQUENCE:
!       Frequency = inverse_cm_to_GHz( Wavenumber )
!
! INPUTS:
!       Wavenumber:   Frequency in inverse centimetres. Must be > 0.0
!                     UNITS:      cm^-1
!                     TYPE:       REAL(fp)
!                     DIMENSION:  Scalar or any rank array
!                     ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
!       Frequency:    The frequency in gigahertz.
!                     Value is 0.0 for an input wavenumber < or = 0.0.
!                     UNITS:      GHz
!                     TYPE:       REAL(fp)
!                     DIMENSION:  Same as input argument
!
! PROCEDURE:
!       The relationship between frequency and wavelength is given by,
!
!              c
!         f = ---  Hz (s^-1)     .....(1)
!              l
!
!       where c = speed of light in m.s^-1
!             l = wavelength in m.
!
!       The conversion of wavelength, l, to frequency, v, in cm^-1, is given by,
!
!                1
!         v = -------  cm^-1     .....(2)
!              100 l
!
!       where the factor of 100 converts l from metres to centimetres.
!       Substituting (2) into (1) gives,
!
!         f = 100 c.v  Hz
!
!           = 10^-9 . 100 c.v  GHz
!
!           = 10^-7 . c.v  GHz
!
!       Therefore the conversion factor from inverse centimeters to GHz is
!       10^-7.c where c is in m.s^-1.
!
!:sdoc-:
!------------------------------------------------------------------------------

  ELEMENTAL FUNCTION inverse_cm_to_GHz( Wavenumber ) RESULT( Frequency )
    REAL(fp), INTENT(IN) :: Wavenumber
    REAL(fp)             :: Frequency
    REAL(fp), PARAMETER  :: SCALE_FACTOR = 1.0e-07_fp
    IF ( Wavenumber < EPSILON(ONE) ) THEN
      Frequency = ZERO
      RETURN
    END IF
    Frequency = SCALE_FACTOR * C * Wavenumber
  END FUNCTION inverse_cm_to_GHz

!------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       micron_to_inverse_cm
!
! PURPOSE:
!       Function to convert wavelengths in units of microns (10^-6 m) to
!       frequencies in units of inverse centimetres (cm^-1).
!
! CALLING SEQUENCE:
!       Wavenumber = micron_to_inverse_cm( Wavelength )
!
! INPUTS:
!       Wavelength:   Wavelength in microns. Must be > 0.0
!                     UNITS:      um (10^-6 m)
!                     TYPE:       REAL(fp)
!                     DIMENSION:  Scalar or any rank array
!                     ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
!       Wavenumber:   The frequency in inverse centimetres.
!                     Value is 0.0 for an input wavelength < or = 0.0.
!                     UNITS:      cm^-1
!                     TYPE:       REAL(fp)
!                     DIMENSION:  Same as input argument
!
! PROCEDURE:
!       Given a wavelength of l microns, the frequency, v, in terms of
!       inverse length is its reciprocal, i.e. the number of wavelengths
!       that "fit" within a certain length dimension,
!
!              1
!         v = --- . 10^6  m^-1
!              l
!
!       where the 10^6 converts the microns to metres. A factor of 100
!       is introduced to produce units of inverse centimetres,
!
!              1     10^6
!         v = --- . ------  m^-1
!              l     10^2
!
!              10^4
!           = ------ cm^-1
!               l
!
!:sdoc-:
!------------------------------------------------------------------------------

  ELEMENTAL FUNCTION micron_to_inverse_cm( Wavelength ) RESULT( Wavenumber )
    REAL(fp), INTENT(IN) :: Wavelength
    REAL(fp)             :: Wavenumber
    REAL(fp), PARAMETER  :: SCALE_FACTOR = 1.0e+04_fp
    IF ( Wavelength < EPSILON(ONE) ) THEN
      Wavenumber = ZERO
      RETURN
    END IF
    Wavenumber = SCALE_FACTOR / Wavelength
  END FUNCTION micron_to_inverse_cm

!------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       inverse_cm_to_micron
!
! PURPOSE:
!       Function to convert frequencies in units of inverse centimetres (cm^-1)
!       to wavelengths in units of microns (10^-6 m).
!
! CALLING SEQUENCE:
!       Wavelength = inverse_cm_to_micron( Wavenumber )
!
! INPUTS:
!       Wavenumber:   Frequency in inverse centimetres. Must be > 0.0
!                     UNITS:      cm^-1
!                     TYPE:       REAL(fp)
!                     DIMENSION:  Scalar or any rank array
!                     ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
!       Wavelength:   The wavelength in microns.
!                     Value is 0.0 for an input wavenumber < or = 0.0.
!                     UNITS:      um (10^-6 m)
!                     TYPE:       REAL(fp)
!                     DIMENSION:  Same as input argument
!
! PROCEDURE:
!       Given a freqency of v inverse centimetres, the wavelength is its
!       reciprocal,
!
!              1       1
!         l = --- . ------  m
!              v     10^2
!
!       where the 10^2 converts the centimetres to metres. A factor of 10^6
!       is introduced to produce units of microns (10^-6 m),
!
!              1     10^6
!         l = --- . ------  um
!              v     10^2
!
!              10^4
!           = ------ um
!               v
!
!:sdoc-:
!------------------------------------------------------------------------------

  ELEMENTAL FUNCTION inverse_cm_to_micron( Wavenumber ) RESULT( Wavelength )
    REAL(fp), INTENT(IN) :: Wavenumber
    REAL(fp)             :: Wavelength
    REAL(fp), PARAMETER  :: SCALE_FACTOR = 1.0e+04_fp
    IF ( Wavenumber < EPSILON(ONE) ) THEN
      Wavelength = ZERO
      RETURN
    END IF
    Wavelength = SCALE_FACTOR / Wavenumber
  END FUNCTION inverse_cm_to_micron

END MODULE Spectral_Units_Conversion


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! S2 PROGRAM
! Author: Brian Krauth, Simon Fraser University
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
program s2
  use bklib, only : DP,setseed  ! machine-specific code
  use smglob ! global variables
  use smle2, only : load_data,estimate,cleanup ! main program calls
! S2MC use monte, only : montecarlo
  implicit none

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!  VARIABLE DECLARATIONS
!
!  Most global variables are defined in the module smglob.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! START EXECUTABLE CODE
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! SETUP
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  call date_and_time(time=STARTTIME) ! get current time
  call setseed() ! reset random number generator - machine specific
! S2REP  do
! S2MC  do
! S2MC  call montecarlo()
  call load_data() ! loads all data and user options from files, initializes and allocates all global variables

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! MAIN ESTIMATION CODE
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
if ((SMGLOBAL%EQUILIBRIUM_TYPE == "B").or.(SMGLOBAL%EQUILIBRIUM_TYPE == "M")) then
   call likelihood_bounds(5)
elseif (SMGLOBAL%EQUILIBRIUM_TYPE == "P") then
   call likelihood_plot(4.0_dp,41)
else ! the usual case
   if (SMGLOBAL%RHO_TYPE == "I") then     ! User has requested interval estimates
      call interval_estimate(0.9_dp,12)
   else
      call estimate()                        ! ESTIMATE is where the model is estimated
      call report_results()
   end if
end if

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! CLEAN UP AND EXIT
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
call cleanup() ! delete all temporary files and lock files

! S2MC  end do
! S2REP end do
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! FUNCTIONS AND SUBROUTINES, IF ANY
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

contains

  subroutine report_results()
    logical :: file_found
    integer :: ios,pos,i
    real(kind=DP) :: loglikelihood,rhox,rhoe,gam
    real(kind=DP), dimension(SMGLOBAL%NVAR+1) :: beta
    real(kind=DP), dimension(SMGLOBAL%NVAR+4,size(BSTAR)) :: h
    h=0.0_dp
    loglikelihood=-fstar
    rhox = BSTAR(1)
    h(1,1) = 1.0_dp
    pos = 2
    if ((SMGLOBAL%RHO_TYPE == "E").or.((SMGLOBAL%RHO_TYPE == "I").and.(SMGLOBAL%RUN_NUMBER == 2))) then
       h(2,pos) = 1.0_dp
       rhoe = BSTAR(pos)
       pos=pos+1
    elseif ((SMGLOBAL%RHO_TYPE == "X").or.((SMGLOBAL%RHO_TYPE == "I").and.(SMGLOBAL%RUN_NUMBER == 1))) then
       rhoe = rhox
       h(2,1) = 1.0_dp
    else
       rhoe = SMGLOBAL%FIXED_RHO
    end if
    if ((SMGLOBAL%FIX_GAMMA).or.((SMGLOBAL%RHO_TYPE == "I").and.(SMGLOBAL%RUN_NUMBER == 2))) then
       gam = SMGLOBAL%FIXED_GAMMA
    else
       h(3,pos) = 1.0_dp
       gam = BSTAR(pos)
       pos=pos+1
    end if
    beta = BSTAR(pos:size(BSTAR))
    do i=4,size(h,1)
       h(i,pos) = 1.0_dp
       pos=pos+1
    end do
    inquire(file=SMGLOBAL%RESULTFILE,exist=file_found) ! see if resultfile already exists
    if (file_found) then
       open(unit=1,file=SMGLOBAL%RESULTFILE,iostat=ios,action="write",position="append",status="old")
    else
       open(unit=1,file=SMGLOBAL%RESULTFILE,iostat=ios,action="write",status="new")
    end if
    if (ios /= 0) then
       stop "Error: cannot write results to result file"
    end if
!    if (SMGLOBAL%RHO_TYPE == "I") then
!       if (SMGLOBAL%RUN_NUMBER == 1) then
!          write (unit=1,iostat=ios,fmt=*) -FSTAR, BSTAR(1), BSTAR
!          if (ios /= 0) then
!             stop "Error: cannot write results to result file"
!          end if
!       elseif (SMGLOBAL%RUN_NUMBER == 2) then
!          write (unit=1,iostat=ios,fmt=*) -FSTAR, BSTAR(1:2), SMGLOBAL%FIXED_GAMMA, BSTAR(3:size(BSTAR))
!          if (ios /= 0) then
!             stop "Error: cannot write results to result file"
!          end if
!       else
!         write (unit=1,iostat=ios,fmt=*) -FSTAR, BSTAR(1), SMGLOBAL%FIXED_RHO, BSTAR(2:size(BSTAR))
    write (unit=1,iostat=ios,fmt=*) loglikelihood,rhox,rhoe,gam,beta ! new
    if (ios /= 0) then
       stop "Error: cannot write results to result file"
    end if
!      end if
!    else
!       write (unit=1,iostat=ios,fmt=*) -FSTAR, BSTAR
!       if (ios /= 0) then
!          stop "Error: cannot write results to result file"
!       end if
!    end if
    if (SMGLOBAL%COVMAT_TYPE /= "N") then
       write (unit=1,iostat=ios,fmt=*) matmul(h,matmul(COVMAT,transpose(h)))
       if (ios /= 0) then
          stop "Error: cannot write results to result file"
       end if
    end if
    close(unit=1,iostat=ios)
    open(unit=1,file=SMGLOBAL%LOGFILE,iostat=ios,action="write",position="append",status="old")
    if (ios == 0) then
       write (unit=1,iostat=ios,fmt=*) "b is: ",BSTAR
       write (unit=1,iostat=ios,fmt=*) "loglikelihood is: ",-FSTAR
       close(unit=1,iostat=ios)
    end if
  end subroutine report_results

  subroutine interval_estimate(rho_max,nsteps)
    real(kind=DP), intent(in) :: rho_max
    integer, intent(in) :: nsteps
    real(kind=DP) :: step
    integer :: i,istart,ios
    step=rho_max/real(nsteps-3,kind=DP)
    istart=SMGLOBAL%RUN_NUMBER
    SMGLOBAL%FIXED_GAMMA=0.001_dp
    SMGLOBAL%FIXED_RHO=0.0_dp
    do i=istart,nsteps
       SMGLOBAL%RUN_NUMBER=i
       if (i==1) then
          continue
       elseif (i==2) then
          SMGLOBAL%FIXED_GAMMA=0.001_dp
          open(unit=1,file=SMGLOBAL%LOGFILE,iostat=ios,action="write",position="append",status="old")
          if (ios == 0) then
             write (unit=1,iostat=ios,fmt=*) "Interval estimation: gamma=0.0"
             close(unit=1,iostat=ios)
          end if
       else
          open(unit=1,file=SMGLOBAL%LOGFILE,iostat=ios,action="write",position="append",status="old")
          if (ios == 0) then
             write (unit=1,iostat=ios,fmt=*) "Interval estimation: rho=",SMGLOBAL%FIXED_RHO
             close(unit=1,iostat=ios)
          end if
       end if
       call estimate()
       call report_results()
       if (i > 2) then
          SMGLOBAL%FIXED_RHO=SMGLOBAL%FIXED_RHO+step
       end if
    end do
  end subroutine interval_estimate

  subroutine likelihood_bounds(nsteps)
    integer, intent(in) :: nsteps
    integer :: i,k,istart,istop,ios
    logical :: file_found
    SMGLOBAL%COVMAT_TYPE="N"
    istart=SMGLOBAL%RUN_NUMBER
    if (istart > 1) then
       k=size(BSTAR)
       deallocate(BSTAR)
       allocate(BSTAR(k-1))
    end if
    if (SMGLOBAL%EQUILIBRIUM_TYPE == "B") then
       istop=2+2*nsteps
    else
       istop=1+nsteps
    end if
    do i=istart,istop
       SMGLOBAL%RUN_NUMBER=i
       if (i==1) then
          call estimate()
          SMGLOBAL%DFPSTOP=FSTAR
          open(unit=1,file=SMGLOBAL%LOGFILE,iostat=ios,action="write",position="append",status="old")
          if (ios == 0) then
             write (unit=1,iostat=ios,fmt=*) "Lower bound for maximum of likelihood function = ", -SMGLOBAL%DFPSTOP
             close(unit=1,iostat=ios)
          end if
          if (SMGLOBAL%RHO_TYPE == "E") then
             SMGLOBAL%GAMMA_START=BSTAR(3)
          else
             SMGLOBAL%GAMMA_START=BSTAR(2)
          end if
          SMGLOBAL%GAMMA_MAX=SMGLOBAL%GAMMA_START
          SMGLOBAL%GAMMA_MIN=0.0_dp
          SMGLOBAL%FIX_GAMMA=.true.
          k=size(BSTAR)
          deallocate(BSTAR)
          allocate(BSTAR(k-1))
       elseif (i < nsteps+2) then
          SMGLOBAL%FIXED_GAMMA=(SMGLOBAL%GAMMA_MIN+SMGLOBAL%GAMMA_MAX)/2.0_dp
          call estimate()
          if (FSTAR < SMGLOBAL%DFPSTOP) then
             SMGLOBAL%GAMMA_MAX=SMGLOBAL%FIXED_GAMMA
          else
             SMGLOBAL%GAMMA_MIN=SMGLOBAL%FIXED_GAMMA
          end if
          if (i== nsteps+1) then
             inquire(file=SMGLOBAL%RESULTFILE,exist=file_found)
             if (file_found) then
                open(unit=1,file=SMGLOBAL%RESULTFILE,iostat=ios,action="write",position="append",status="old")
             else
                open(unit=1,file=SMGLOBAL%RESULTFILE,iostat=ios,action="write",status="new")
             end if
             if (ios /= 0) then
                stop "Error: cannot write results to file"
             else
                write (unit=1,iostat=ios,fmt=*) (SMGLOBAL%GAMMA_MAX+SMGLOBAL%GAMMA_MIN)/2.0_dp
                close (unit=1,iostat=ios)
             end if
          end if
       elseif (i == nsteps+2) then
          SMGLOBAL%GAMMA_MIN=SMGLOBAL%GAMMA_START
          SMGLOBAL%GAMMA_MAX=4.0_dp
          SMGLOBAL%FIXED_GAMMA=4.0_dp
          call estimate()
          if (FSTAR < SMGLOBAL%DFPSTOP) then
             open(unit=1,file=SMGLOBAL%LOGFILE,iostat=ios,action="write",position="append",status="old")
             if (ios == 0) then
                write (unit=1,iostat=ios,fmt=*) "Upper bound for gamma is > 4.0, stopping calculation there"
                close(unit=1,iostat=ios)
             end if
             open(unit=1,file=SMGLOBAL%RESULTFILE,iostat=ios,action="write",position="append",status="old")
             if (ios == 0) then
                write (unit=1,iostat=ios,fmt=*) 4.0_dp
                close (unit=1,iostat=ios)
             else
                stop "Error: cannot write results to file"
             end if
             return
          end if
       else
          SMGLOBAL%FIXED_GAMMA=(SMGLOBAL%GAMMA_MIN+SMGLOBAL%GAMMA_MAX)/2.0_dp
          call estimate()
          if (FSTAR < SMGLOBAL%DFPSTOP) then
             SMGLOBAL%GAMMA_MIN=SMGLOBAL%FIXED_GAMMA
          else
             SMGLOBAL%GAMMA_MAX=SMGLOBAL%FIXED_GAMMA
          endif
          if (i == (2+2*nsteps)) then
             open(unit=1,file=SMGLOBAL%RESULTFILE,iostat=ios,action="write",position="append",status="old")
             if (ios == 0) then
                write (unit=1,iostat=ios,fmt=*) (SMGLOBAL%GAMMA_MAX+SMGLOBAL%GAMMA_MIN)/2.0_dp
                close (unit=1,iostat=ios)
             else
                stop "Error: cannot write results to file"
             end if
          end if
       end if
       open(unit=1,file=SMGLOBAL%LOGFILE,iostat=ios,action="write",position="append",status="old")
       if (ios == 0) then
          if (i > 1) then
             write (unit=1,iostat=ios,fmt=*) "Gamma is: ", SMGLOBAL%FIXED_GAMMA
          end if
          write (unit=1,iostat=ios,fmt=*) "b is: ",BSTAR
          write (unit=1,iostat=ios,fmt=*) "loglikelihood is: ",-FSTAR
          close (unit=1,iostat=ios)
       end if
    end do
  end subroutine likelihood_bounds

  subroutine likelihood_plot(gamma_max,nsteps)
    real(kind=DP), intent(in) :: gamma_max
    integer, intent(in) :: nsteps
    real(kind=DP) :: step
    integer :: i,istart,istop,ios
    logical :: file_found
    step = gamma_max/real(nsteps-1,kind=DP)
    SMGLOBAL%FIX_GAMMA=.true.
    SMGLOBAL%FIXED_GAMMA=0.0_dp
    istart=SMGLOBAL%RUN_NUMBER
    istop=2*nsteps
    do i=istart,istop
       SMGLOBAL%RUN_NUMBER=i
       call estimate()
       inquire(file=SMGLOBAL%RESULTFILE,exist=file_found) ! see if resultfile already exists
       if (file_found) then
          open(unit=1,file=SMGLOBAL%RESULTFILE,iostat=ios,action="write",position="append",status="old")
       else
          open(unit=1,file=SMGLOBAL%RESULTFILE,iostat=ios,action="write",status="new")
       end if
       if (ios == 0) then
          if (modulo(i,2) > 0) then
             write (unit=1,iostat=ios,fmt=*) SMGLOBAL%FIXED_GAMMA, -FSTAR
          else
             write (unit=1,iostat=ios,fmt=*) -FSTAR
             SMGLOBAL%FIXED_GAMMA = SMGLOBAL%FIXED_GAMMA+step
          end if
          close (unit=1,iostat=ios)
       else
          stop "Error: cannot write results to file"
       end if
    end do
  end subroutine likelihood_plot

end program s2


      program sprint2
ccc it uses the adjacency matrix like in sprint (with real numbers)
ccc the Laplacian is based on a adjacency with whole numbers
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      integer,dimension(:,:),allocatable :: ia
      integer,dimension(:),allocatable :: ideg
      real,dimension(:,:),allocatable :: a,al
      real,dimension(:),allocatable :: deg,s,d,e,f

      amaxi=-1d200
      read(5,*) m,natom
      print*, "Natom=",natom
      allocate(a(natom,natom),al(natom,natom),ia(natom,natom))
      allocate(deg(natom),s(natom),d(natom),e(natom),f(natom),
     &ideg(natom))
      print*, "steps=",m
      do i=1,m
         print*, "Step",i
         print*, "Adjacency matrix"
         do j=1,natom
            read(5,*)  (a(j,k),k=1,natom)
c            print*,  (a(j,k),k=1,natom)
            print "(999f18.8)",  (a(j,k),k=1,natom)
            deg(j)=0.d0
            do k=1,natom
               deg(j)=deg(j)+a(j,k)
            enddo
         enddo
         do j=1,natom
            read(5,*)  (ia(j,k),k=1,natom)
            ideg(j)=0
            do k=1,natom
               ideg(j)=ideg(j)+ia(j,k)
            enddo
         enddo
         print*, "deg of each vertex"
         do k=1,natom
            print*, deg(k)
         enddo

         print*, "Laplacian of the graph"
         do ii=1,natom
            do jj=1,natom
               if(ii.eq.jj) al(ii,jj)=dble(ideg(ii))
               if(ii.ne.jj) al(ii,jj)=-dble(ia(ii,jj))
            enddo
c            print*,  (al(ii,k),k=1,natom)
            print "(999f18.8)",  (al(ii,k),k=1,natom)
         enddo
cccc
         call tred2(a,natom,natom,d,e)
         call tqli(d,e,natom,natom,a)

         do jj=1,natom
            if(d(jj)>amaxi) then
               imaxi=jj
               amaxi=d(jj)
            endif
         enddo

         do jj=1,natom-1
            do kk=jj+1,natom
               if(d(jj)>d(kk)) then
                  temp=d(kk)
                  d(kk)=d(jj)
                  d(jj)=temp
               endif
            enddo
         enddo
         write(6,3) (d(ii),ii=1,natom)
         sumsq=0
         sumst=0
         do kk=1,natom
            sumsq=sumsq+d(kk)*d(kk)
            sumst=sumst+d(kk)*d(kk)*d(kk)
            dum=a(kk,imaxi)
            a(kk,imaxi)=sqrt(dum*dum)
         enddo
         write(6,4) sumsq/2.d0
         write(6,5) sumst/6.d0
         do jj=1,natom-1
            do kk=jj+1,natom
               if(a(jj,imaxi)>a(kk,imaxi)) then
                  temp=a(kk,imaxi)
                  a(kk,imaxi)=a(jj,imaxi)
                  a(jj,imaxi)=temp
               endif
            enddo
         enddo
         cc=sqrt(real(natom))*d(natom)
         do k=1,natom
            s(k)=cc*a(k,imaxi)
         enddo
         write(6,1) (a(j,imaxi),j=1,natom)
         write(6,2) (s(j),j=1,natom)
ccc
         write(*,*)
         print*, "Results for the Laplacian"
         call tred2(al,natom,natom,d,e)
         call tqli(d,e,natom,natom,al)
         do jj=1,natom-1
            do kk=jj+1,natom
               if(d(jj)>d(kk)) then
                  temp=d(kk)
                  d(kk)=d(jj)
                  d(jj)=temp
               endif
            enddo
         enddo
         write(6,3) (d(ii),ii=1,natom)

      enddo

1     format('EigenVector of lambda_max      ',90f12.3)
2     format('Sprint coordinates ordered     ',90f12.3)
3     format('Lambda (from lowest to highest)',90f12.3)
4     format('(Sum Lambda^2)/2 (# of bonds  )',90f12.3)
5     format('(Sum Lambda^3)/6 (# of triangs)',90f12.3)
      end

      SUBROUTINE TRED2(A,N,NP,D,E)
      DIMENSION A(NP,NP),D(NP),E(NP)
      IF(N.GT.1)THEN
        DO 18 I=N,2,-1
          L=I-1
          H=0.
          SCALE=0.
          IF(L.GT.1)THEN
            DO 11 K=1,L
              SCALE=SCALE+ABS(A(I,K))
11          CONTINUE
            IF(SCALE.EQ.0.)THEN
              E(I)=A(I,L)
            ELSE
              DO 12 K=1,L
                A(I,K)=A(I,K)/SCALE
                H=H+A(I,K)**2
12            CONTINUE
              F=A(I,L)
              G=-SIGN(SQRT(H),F)
              E(I)=SCALE*G
              H=H-F*G
              A(I,L)=F-G
              F=0.
              DO 15 J=1,L
                A(J,I)=A(I,J)/H
                G=0.
                DO 13 K=1,J
                  G=G+A(J,K)*A(I,K)
13              CONTINUE
                IF(L.GT.J)THEN
                  DO 14 K=J+1,L
                    G=G+A(K,J)*A(I,K)
14                CONTINUE
                ENDIF
                E(J)=G/H
                F=F+E(J)*A(I,J)
15            CONTINUE
              HH=F/(H+H)
              DO 17 J=1,L
                F=A(I,J)
                G=E(J)-HH*F
                E(J)=G
                DO 16 K=1,J
                  A(J,K)=A(J,K)-F*E(K)-G*A(I,K)
16              CONTINUE
17            CONTINUE
            ENDIF
          ELSE
            E(I)=A(I,L)
          ENDIF
          D(I)=H
18      CONTINUE
      ENDIF
      D(1)=0.
      E(1)=0.
      DO 23 I=1,N
        L=I-1
        IF(D(I).NE.0.)THEN
          DO 21 J=1,L
            G=0.
            DO 19 K=1,L
              G=G+A(I,K)*A(K,J)
19          CONTINUE
            DO 20 K=1,L
              A(K,J)=A(K,J)-G*A(K,I)
20          CONTINUE
21        CONTINUE
        ENDIF
        D(I)=A(I,I)
        A(I,I)=1.
        IF(L.GE.1)THEN
          DO 22 J=1,L
            A(I,J)=0.
            A(J,I)=0.
22        CONTINUE
        ENDIF
23    CONTINUE
      RETURN
      END

      SUBROUTINE TQLI(D,E,N,NP,Z)
      DIMENSION D(NP),E(NP),Z(NP,NP)
      IF (N.GT.1) THEN
        DO 11 I=2,N
          E(I-1)=E(I)
11      CONTINUE
        E(N)=0.
        DO 15 L=1,N
          ITER=0
1         DO 12 M=L,N-1
            DD=ABS(D(M))+ABS(D(M+1))
            IF (ABS(E(M))+DD.EQ.DD) GO TO 2
12        CONTINUE
          M=N
2         IF(M.NE.L)THEN
            IF(ITER.EQ.30) then
               print*, 'too many iterations'
               call exit
            endif
            ITER=ITER+1
            G=(D(L+1)-D(L))/(2.*E(L))
            R=SQRT(G**2+1.)
            G=D(M)-D(L)+E(L)/(G+SIGN(R,G))
            S=1.
            C=1.
            P=0.
            DO 14 I=M-1,L,-1
              F=S*E(I)
              B=C*E(I)
              IF(ABS(F).GE.ABS(G))THEN
                C=G/F
                R=SQRT(C**2+1.)
                E(I+1)=F*R
                S=1./R
                C=C*S
              ELSE
                S=F/G
                R=SQRT(S**2+1.)
                E(I+1)=G*R
                C=1./R
                S=S*C
              ENDIF
              G=D(I+1)-P
              R=(D(I)-G)*S+2.*C*B
              P=S*R
              D(I+1)=G+P
              G=C*R-B
              DO 13 K=1,N
                F=Z(K,I+1)
                Z(K,I+1)=S*Z(K,I)+C*F
                Z(K,I)=C*Z(K,I)-S*F
13            CONTINUE
14          CONTINUE
            D(L)=D(L)-P
            E(L)=G
            E(M)=0.
            GO TO 1
          ENDIF
15      CONTINUE
      ENDIF
      RETURN
      END


*DECK BESJ
      SUBROUTINE BESJ (X, ALPHA, N, Y, NZ)
C***BEGIN PROLOGUE  BESJ
C***PURPOSE  Compute an N member sequence of J Bessel functions
C            J/SUB(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA
C            and X.
C***LIBRARY   SLATEC
C***CATEGORY  C10A3
C***TYPE      SINGLE PRECISION (BESJ-S, DBESJ-D)
C***KEYWORDS  J BESSEL FUNCTION, SPECIAL FUNCTIONS
C***AUTHOR  Amos, D. E., (SNLA)
C           Daniel, S. L., (SNLA)
C           Weston, M. K., (SNLA)
C***DESCRIPTION
C
C     Abstract
C         BESJ computes an N member sequence of J Bessel functions
C         J/sub(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA and X.
C         A combination of the power series, the asymptotic expansion
C         for X to infinity and the uniform asymptotic expansion for
C         NU to infinity are applied over subdivisions of the (NU,X)
C         plane.  For values of (NU,X) not covered by one of these
C         formulae, the order is incremented or decremented by integer
C         values into a region where one of the formulae apply. Backward
C         recursion is applied to reduce orders by integer values except
C         where the entire sequence lies in the oscillatory region.  In
C         this case forward recursion is stable and values from the
C         asymptotic expansion for X to infinity start the recursion
C         when it is efficient to do so.  Leading terms of the series
C         and uniform expansion are tested for underflow.  If a sequence
C         is requested and the last member would underflow, the result
C         is set to zero and the next lower order tried, etc., until a
C         member comes on scale or all members are set to zero.
C         Overflow cannot occur.
C
C     Description of Arguments
C
C         Input
C           X      - X .GE. 0.0E0
C           ALPHA  - order of first member of the sequence,
C                    ALPHA .GE. 0.0E0
C           N      - number of members in the sequence, N .GE. 1
C
C         Output
C           Y      - a vector whose first  N components contain
C                    values for J/sub(ALPHA+K-1)/(X), K=1,...,N
C           NZ     - number of components of Y set to zero due to
C                    underflow,
C                    NZ=0   , normal return, computation completed
C                    NZ .NE. 0, last NZ components of Y set to zero,
C                             Y(K)=0.0E0, K=N-NZ+1,...,N.
C
C     Error Conditions
C         Improper input arguments - a fatal error
C         Underflow  - a non-fatal error (NZ .NE. 0)
C
C***REFERENCES  D. E. Amos, S. L. Daniel and M. K. Weston, CDC 6600
C                 subroutines IBESS and JBESS for Bessel functions
C                 I(NU,X) and J(NU,X), X .GE. 0, NU .GE. 0, ACM
C                 Transactions on Mathematical Software 3, (1977),
C                 pp. 76-92.
C               F. W. J. Olver, Tables of Bessel Functions of Moderate
C                 or Large Orders, NPL Mathematical Tables 6, Her
C                 Majesty's Stationery Office, London, 1962.
C***ROUTINES CALLED  ALNGAM, ASYJY, I1MACH, JAIRY, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   750101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BESJ
      EXTERNAL JAIRY
      INTEGER I,IALP,IDALP,IFLW,IN,INLIM,IS,I1,I2,K,KK,KM,KT,N,NN,
     1        NS,NZ
      INTEGER I1MACH
      REAL       AK,AKM,ALPHA,ANS,AP,ARG,COEF,DALPHA,DFN,DTM,EARG,
     1           ELIM1,ETX,FIDAL,FLGJY,FN,FNF,FNI,FNP1,FNU,FNULIM,
     2           GLN,PDF,PIDT,PP,RDEN,RELB,RTTP,RTWO,RTX,RZDEN,
     3           S,SA,SB,SXO2,S1,S2,T,TA,TAU,TB,TEMP,TFN,TM,TOL,
     4           TOLLN,TRX,TX,T1,T2,WK,X,XO2,XO2L,Y,RTOL,SLIM
      SAVE RTWO, PDF, RTTP, PIDT, PP, INLIM, FNULIM
      REAL R1MACH, ALNGAM
      DIMENSION Y(*), TEMP(3), FNULIM(2), PP(4), WK(7)
      DATA RTWO,PDF,RTTP,PIDT                    / 1.34839972492648E+00,
     1 7.85398163397448E-01, 7.97884560802865E-01, 1.57079632679490E+00/
      DATA  PP(1),  PP(2),  PP(3),  PP(4)        / 8.72909153935547E+00,
     1 2.65693932265030E-01, 1.24578576865586E-01, 7.70133747430388E-04/
      DATA INLIM           /      150            /
      DATA FNULIM(1), FNULIM(2) /      100.0E0,     60.0E0     /
C***FIRST EXECUTABLE STATEMENT  BESJ
      NZ = 0
      KT = 1
      NS=0
C     I1MACH(14) REPLACES I1MACH(11) IN A DOUBLE PRECISION CODE
C     I1MACH(15) REPLACES I1MACH(12) IN A DOUBLE PRECISION CODE
      TA = R1MACH(3)
      TOL = MAX(TA,1.0E-15)
      I1 = I1MACH(11) + 1
      I2 = I1MACH(12)
      TB = R1MACH(5)
      ELIM1 = -2.303E0*(I2*TB+3.0E0)
      RTOL=1.0E0/TOL
      SLIM=R1MACH(1)*1.0E+3*RTOL
C     TOLLN = -LN(TOL)
      TOLLN = 2.303E0*TB*I1
      TOLLN = MIN(TOLLN,34.5388E0)
      IF (N-1) 720, 10, 20
   10 KT = 2
   20 NN = N
      IF (X) 730, 30, 80
   30 IF (ALPHA) 710, 40, 50
   40 Y(1) = 1.0E0
      IF (N.EQ.1) RETURN
      I1 = 2
      GO TO 60
   50 I1 = 1
   60 DO 70 I=I1,N
        Y(I) = 0.0E0
   70 CONTINUE
      RETURN
   80 CONTINUE
      IF (ALPHA.LT.0.0E0) GO TO 710
C
      IALP = INT(ALPHA)
      FNI = IALP + N - 1
      FNF = ALPHA - IALP
      DFN = FNI + FNF
      FNU = DFN
      XO2 = X*0.5E0
      SXO2 = XO2*XO2
C
C     DECISION TREE FOR REGION WHERE SERIES, ASYMPTOTIC EXPANSION FOR X
C     TO INFINITY AND ASYMPTOTIC EXPANSION FOR NU TO INFINITY ARE
C     APPLIED.
C
      IF (SXO2.LE.(FNU+1.0E0)) GO TO 90
      TA = MAX(20.0E0,FNU)
      IF (X.GT.TA) GO TO 120
      IF (X.GT.12.0E0) GO TO 110
      XO2L = LOG(XO2)
      NS = INT(SXO2-FNU) + 1
      GO TO 100
   90 FN = FNU
      FNP1 = FN + 1.0E0
      XO2L = LOG(XO2)
      IS = KT
      IF (X.LE.0.50E0) GO TO 330
      NS = 0
  100 FNI = FNI + NS
      DFN = FNI + FNF
      FN = DFN
      FNP1 = FN + 1.0E0
      IS = KT
      IF (N-1+NS.GT.0) IS = 3
      GO TO 330
  110 ANS = MAX(36.0E0-FNU,0.0E0)
      NS = INT(ANS)
      FNI = FNI + NS
      DFN = FNI + FNF
      FN = DFN
      IS = KT
      IF (N-1+NS.GT.0) IS = 3
      GO TO 130
  120 CONTINUE
      RTX = SQRT(X)
      TAU = RTWO*RTX
      TA = TAU + FNULIM(KT)
      IF (FNU.LE.TA) GO TO 480
      FN = FNU
      IS = KT
C
C     UNIFORM ASYMPTOTIC EXPANSION FOR NU TO INFINITY
C
  130 CONTINUE
      I1 = ABS(3-IS)
      I1 = MAX(I1,1)
      FLGJY = 1.0E0
      CALL ASYJY(JAIRY,X,FN,FLGJY,I1,TEMP(IS),WK,IFLW)
      IF(IFLW.NE.0) GO TO 380
      GO TO (320, 450, 620), IS
  310 TEMP(1) = TEMP(3)
      KT = 1
  320 IS = 2
      FNI = FNI - 1.0E0
      DFN = FNI + FNF
      FN = DFN
      IF(I1.EQ.2) GO TO 450
      GO TO 130
C
C     SERIES FOR (X/2)**2.LE.NU+1
C
  330 CONTINUE
      GLN = ALNGAM(FNP1)
      ARG = FN*XO2L - GLN
      IF (ARG.LT.(-ELIM1)) GO TO 400
      EARG = EXP(ARG)
  340 CONTINUE
      S = 1.0E0
      IF (X.LT.TOL) GO TO 360
      AK = 3.0E0
      T2 = 1.0E0
      T = 1.0E0
      S1 = FN
      DO 350 K=1,17
        S2 = T2 + S1
        T = -T*SXO2/S2
        S = S + T
        IF (ABS(T).LT.TOL) GO TO 360
        T2 = T2 + AK
        AK = AK + 2.0E0
        S1 = S1 + FN
  350 CONTINUE
  360 CONTINUE
      TEMP(IS) = S*EARG
      GO TO (370, 450, 610), IS
  370 EARG = EARG*FN/XO2
      FNI = FNI - 1.0E0
      DFN = FNI + FNF
      FN = DFN
      IS = 2
      GO TO 340
C
C     SET UNDERFLOW VALUE AND UPDATE PARAMETERS
C     UNDERFLOW CAN ONLY OCCUR FOR NS=0 SINCE THE ORDER MUST BE
C     LARGER THAN 36. THEREFORE, NS NEED NOT BE CONSIDERED.
C
  380 Y(NN) = 0.0E0
      NN = NN - 1
      FNI = FNI - 1.0E0
      DFN = FNI + FNF
      FN = DFN
      IF (NN-1) 440, 390, 130
  390 KT = 2
      IS = 2
      GO TO 130
  400 Y(NN) = 0.0E0
      NN = NN - 1
      FNP1 = FN
      FNI = FNI - 1.0E0
      DFN = FNI + FNF
      FN = DFN
      IF (NN-1) 440, 410, 420
  410 KT = 2
      IS = 2
  420 IF (SXO2.LE.FNP1) GO TO 430
      GO TO 130
  430 ARG = ARG - XO2L + LOG(FNP1)
      IF (ARG.LT.(-ELIM1)) GO TO 400
      GO TO 330
  440 NZ = N - NN
      RETURN
C
C     BACKWARD RECURSION SECTION
C
  450 CONTINUE
      IF(NS.NE.0) GO TO 451
      NZ = N - NN
      IF (KT.EQ.2) GO TO 470
C     BACKWARD RECUR FROM INDEX ALPHA+NN-1 TO ALPHA
      Y(NN) = TEMP(1)
      Y(NN-1) = TEMP(2)
      IF (NN.EQ.2) RETURN
  451 CONTINUE
      TRX = 2.0E0/X
      DTM = FNI
      TM = (DTM+FNF)*TRX
      AK=1.0E0
      TA=TEMP(1)
      TB=TEMP(2)
      IF(ABS(TA).GT.SLIM) GO TO 455
      TA=TA*RTOL
      TB=TB*RTOL
      AK=TOL
  455 CONTINUE
      KK=2
      IN=NS-1
      IF(IN.EQ.0) GO TO 690
      IF(NS.NE.0) GO TO 670
      K=NN-2
      DO 460 I=3,NN
        S=TB
        TB=TM*TB-TA
        TA=S
        Y(K)=TB*AK
        K=K-1
        DTM = DTM - 1.0E0
        TM = (DTM+FNF)*TRX
  460 CONTINUE
      RETURN
  470 Y(1) = TEMP(2)
      RETURN
C
C     ASYMPTOTIC EXPANSION FOR X TO INFINITY WITH FORWARD RECURSION IN
C     OSCILLATORY REGION X.GT.MAX(20, NU), PROVIDED THE LAST MEMBER
C     OF THE SEQUENCE IS ALSO IN THE REGION.
C
  480 CONTINUE
      IN = INT(ALPHA-TAU+2.0E0)
      IF (IN.LE.0) GO TO 490
      IDALP = IALP - IN - 1
      KT = 1
      GO TO 500
  490 CONTINUE
      IDALP = IALP
      IN = 0
  500 IS = KT
      FIDAL = IDALP
      DALPHA = FIDAL + FNF
      ARG = X - PIDT*DALPHA - PDF
      SA = SIN(ARG)
      SB = COS(ARG)
      COEF = RTTP/RTX
      ETX = 8.0E0*X
  510 CONTINUE
      DTM = FIDAL + FIDAL
      DTM = DTM*DTM
      TM = 0.0E0
      IF (FIDAL.EQ.0.0E0 .AND. ABS(FNF).LT.TOL) GO TO 520
      TM = 4.0E0*FNF*(FIDAL+FIDAL+FNF)
  520 CONTINUE
      TRX = DTM - 1.0E0
      T2 = (TRX+TM)/ETX
      S2 = T2
      RELB = TOL*ABS(T2)
      T1 = ETX
      S1 = 1.0E0
      FN = 1.0E0
      AK = 8.0E0
      DO 530 K=1,13
        T1 = T1 + ETX
        FN = FN + AK
        TRX = DTM - FN
        AP = TRX + TM
        T2 = -T2*AP/T1
        S1 = S1 + T2
        T1 = T1 + ETX
        AK = AK + 8.0E0
        FN = FN + AK
        TRX = DTM - FN
        AP = TRX + TM
        T2 = T2*AP/T1
        S2 = S2 + T2
        IF (ABS(T2).LE.RELB) GO TO 540
        AK = AK + 8.0E0
  530 CONTINUE
  540 TEMP(IS) = COEF*(S1*SB-S2*SA)
      IF(IS.EQ.2) GO TO 560
      FIDAL = FIDAL + 1.0E0
      DALPHA = FIDAL + FNF
      IS = 2
      TB = SA
      SA = -SB
      SB = TB
      GO TO 510
C
C     FORWARD RECURSION SECTION
C
  560 IF (KT.EQ.2) GO TO 470
      S1 = TEMP(1)
      S2 = TEMP(2)
      TX = 2.0E0/X
      TM = DALPHA*TX
      IF (IN.EQ.0) GO TO 580
C
C     FORWARD RECUR TO INDEX ALPHA
C
      DO 570 I=1,IN
        S = S2
        S2 = TM*S2 - S1
        TM = TM + TX
        S1 = S
  570 CONTINUE
      IF (NN.EQ.1) GO TO 600
      S = S2
      S2 = TM*S2 - S1
      TM = TM + TX
      S1 = S
  580 CONTINUE
C
C     FORWARD RECUR FROM INDEX ALPHA TO ALPHA+N-1
C
      Y(1) = S1
      Y(2) = S2
      IF (NN.EQ.2) RETURN
      DO 590 I=3,NN
        Y(I) = TM*Y(I-1) - Y(I-2)
        TM = TM + TX
  590 CONTINUE
      RETURN
  600 Y(1) = S2
      RETURN
C
C     BACKWARD RECURSION WITH NORMALIZATION BY
C     ASYMPTOTIC EXPANSION FOR NU TO INFINITY OR POWER SERIES.
C
  610 CONTINUE
C     COMPUTATION OF LAST ORDER FOR SERIES NORMALIZATION
      AKM = MAX(3.0E0-FN,0.0E0)
      KM = INT(AKM)
      TFN = FN + KM
      TA = (GLN+TFN-0.9189385332E0-0.0833333333E0/TFN)/(TFN+0.5E0)
      TA = XO2L - TA
      TB = -(1.0E0-1.5E0/TFN)/TFN
      AKM = TOLLN/(-TA+SQRT(TA*TA-TOLLN*TB)) + 1.5E0
      IN = KM + INT(AKM)
      GO TO 660
  620 CONTINUE
C     COMPUTATION OF LAST ORDER FOR ASYMPTOTIC EXPANSION NORMALIZATION
      GLN = WK(3) + WK(2)
      IF (WK(6).GT.30.0E0) GO TO 640
      RDEN = (PP(4)*WK(6)+PP(3))*WK(6) + 1.0E0
      RZDEN = PP(1) + PP(2)*WK(6)
      TA = RZDEN/RDEN
      IF (WK(1).LT.0.10E0) GO TO 630
      TB = GLN/WK(5)
      GO TO 650
  630 TB=(1.259921049E0+(0.1679894730E0+0.0887944358E0*WK(1))*WK(1))
     1 /WK(7)
      GO TO 650
  640 CONTINUE
      TA = 0.5E0*TOLLN/WK(4)
      TA=((0.0493827160E0*TA-0.1111111111E0)*TA+0.6666666667E0)*TA*WK(6)
      IF (WK(1).LT.0.10E0) GO TO 630
      TB = GLN/WK(5)
  650 IN = INT(TA/TB+1.5E0)
      IF (IN.GT.INLIM) GO TO 310
  660 CONTINUE
      DTM = FNI + IN
      TRX = 2.0E0/X
      TM = (DTM+FNF)*TRX
      TA = 0.0E0
      TB = TOL
      KK = 1
      AK=1.0E0
  670 CONTINUE
C
C     BACKWARD RECUR UNINDEXED AND SCALE WHEN MAGNITUDES ARE CLOSE TO
C     UNDERFLOW LIMITS (LESS THAN SLIM=R1MACH(1)*1.0E+3/TOL)
C
      DO 680 I=1,IN
        S = TB
        TB = TM*TB - TA
        TA = S
        DTM = DTM - 1.0E0
        TM = (DTM+FNF)*TRX
  680 CONTINUE
C     NORMALIZATION
      IF (KK.NE.1) GO TO 690
      S=TEMP(3)
      SA=TA/TB
      TA=S
      TB=S
      IF(ABS(S).GT.SLIM) GO TO 685
      TA=TA*RTOL
      TB=TB*RTOL
      AK=TOL
  685 CONTINUE
      TA=TA*SA
      KK = 2
      IN = NS
      IF (NS.NE.0) GO TO 670
  690 Y(NN) = TB*AK
      NZ = N - NN
      IF (NN.EQ.1) RETURN
      K = NN - 1
      S=TB
      TB = TM*TB - TA
      TA=S
      Y(K)=TB*AK
      IF (NN.EQ.2) RETURN
      DTM = DTM - 1.0E0
      TM = (DTM+FNF)*TRX
      K=NN-2
C
C     BACKWARD RECUR INDEXED
C
      DO 700 I=3,NN
        S=TB
        TB = TM*TB - TA
        TA=S
        Y(K)=TB*AK
        DTM = DTM - 1.0E0
        TM = (DTM+FNF)*TRX
        K = K - 1
  700 CONTINUE
      RETURN
C
C
C
  710 CONTINUE
      CALL XERMSG ('SLATEC', 'BESJ', 'ORDER, ALPHA, LESS THAN ZERO.',
     +   2, 1)
      RETURN
  720 CONTINUE
      CALL XERMSG ('SLATEC', 'BESJ', 'N LESS THAN ONE.', 2, 1)
      RETURN
  730 CONTINUE
      CALL XERMSG ('SLATEC', 'BESJ', 'X LESS THAN ZERO.', 2, 1)
      RETURN
      END


module parameter_mod
  integer, parameter ::   one_byte = selected_int_kind(2)   !   One byte integer
  integer, parameter ::   two_byte = selected_int_kind(3)   !   Two byte integer
  integer, parameter ::  four_byte = selected_int_kind(5)   !  Four byte integer
  integer, parameter :: eight_byte = selected_int_kind(15)  !  Eight byte integer
end module parameter_mod

program foo
  use parameter_mod
  print *, one_byte, two_byte, four_byte, eight_byte
end program foo


C ***
C       PROGRAM colour
C c-------------------------------------------------------------c
C c
C c     Example program to show how to compute colours
C c     using Kurucz and Bergeron (WDs) model atmosphere data.
C c     Requires data files:
C c         Kurucz.dat
C c         (Kurucz, 1992, Proc. IAU Symp. 149, p. 225)
C c         wdhyd.dat
C c         (Bergeron, Wesemael & Beauchamp, 1995, PASP, 107, 1047)
C c     Written by Jarrod Hurley 10/08/06.
C c
C c-------------------------------------------------------------c
C       implicit none
C *
C       INTEGER kw
C *
C       REAL*8 z,massi,logl,logr,logte,logz,bolc
C       REAL*8 mv,mb,bminv,vmini,uminb
C       REAL*8 mv1,mv2,bminv1,bminv2
C *
C * Set metallicity.
C *
C       z = 0.001d0
C       logz = log10(z/0.02)
C *
C * Read in the bolometric correction tables.
C *
C       CALL ubvtab
C *
C * Mass, luminosity and radius of a star (as well as metallicity)
C * are required to compute colours. Here are some test values:
C * 2 Msun turn-off star, Z = 0.001
C       massi = 2.0
C       logl = 1.8355
C       logr = 0.3955
C * 1.3 Msun turn-off star, Z = 0.02
C *     massi = 1.3
C *     logl = 0.7574
C *     logr = 0.3369
C * 0.55 Msun cool WD
C *     massi = 0.55
C *     logl = -3.1694
C *     logr = -1.8712
C *
C       logte = 3.762d0 + 0.25d0*logl - 0.5d0*logr
C       if(kw.ge.10.and.kw.le.12)then
C          CALL wd2ubv(logl,logte,massi,bolc,mv,
C      &               uminb,bminv,vmini)
C       else
C          CALL lt2ubv(logl,logte,massi,logz,bolc,mv,
C      &               uminb,bminv,vmini)
C       endif
C       mb = mv + bminv
C *
C       WRITE(*,*)
C       WRITE(*,*)' Single Star:'
C       WRITE(*,*)'              Mv ',mv
C       WRITE(*,*)'              Mb ',mb
C       WRITE(*,*)'             U-B ',uminb
C       WRITE(*,*)'             B-V ',bminv
C       WRITE(*,*)'             V-I ',vmini
C *
C * Here is an example for an unresolved binary.
C *
C       mv1 = mv
C       bminv1 = bminv
C *
C * Take a 0.55 Msun WD companion.
C       massi = 0.55
C       logl = -3.1694
C       logr = -1.8712
C *
C       logte = 3.762d0 + 0.25d0*logl - 0.5d0*logr
C       if(kw.ge.10.and.kw.le.12)then
C          CALL wd2ubv(logl,logte,massi,bolc,mv2,
C      &               uminb,bminv2,vmini)
C       else
C          CALL lt2ubv(logl,logte,massi,logz,bolc,mv2,
C      &               uminb,bminv2,vmini)
C       endif
C *
C * Add fluxes to get combined magnitudes.
C       mv = -2.5d0*log10(10.d0**(-0.4d0*mv1) + 10.d0**(-0.4d0*mv2))
C       mb = -2.5d0*log10(10.d0**(-0.4d0*(mv1+bminv1)) +
C      &                  10.d0**(-0.4d0*(mv2+bminv2)))
C       bminv = mb - mv
C *
C       WRITE(*,*)
C       WRITE(*,*)' Binary Star:'
C       WRITE(*,*)'              Mv ',mv
C       WRITE(*,*)'              Mb ',mb
C       WRITE(*,*)'             B-V ',bminv
C *
C       STOP
C       END
***
      SUBROUTINE ubvtab
      implicit none
*
      INTEGER i,j,k,n
      INTEGER nzgr,ntgr,nggr
      PARAMETER(nzgr=8,ntgr=61,nggr= 11)
      INTEGER ntgr2,nggr2
      PARAMETER(ntgr2=91,nggr2=5)
*
      REAL feh
      REAL*8 zgr(nzgr),tgr(ntgr),ggr(nggr),ubv(nzgr,ntgr,nggr,5)
      COMMON /ubvdata/ zgr,tgr,ggr,ubv
      REAL*8 wtgr(ntgr2),wggr(nggr2),wubv(ntgr2,nggr2,5)
      COMMON /wubvdata/ wtgr,wggr,wubv
      CHARACTER*200 datadir
      COMMON /AMUSE/ datadir

*
*cello, dir mod
      OPEN(23,file=trim(datadir)//'/static/Kurucz.dat',
     &        form='formatted',status='old')
      do k = 1, nzgr
         do i = 1, ntgr
            do j = 1, nggr
               read(23,*)feh,tgr(i),ggr(j),(ubv(k,i,j,n),n=1,5)
            end do
            tgr(i) = log10(tgr(i))
         end do
c....... zgr=log(Z/0.02), assuming X=0.76-3*Z and Z(sun)=0.02
         zgr(k) = -log10((3.d0 + 37.425d0*10.d0**(-feh))/38.d0)
*        zgr(k) = -log10(0.07895 + 0.92105*10.0**(-feh))
      end do
      CLOSE(23)
*
      OPEN(24,file=trim(datadir)//'/static/wdhyd.dat',
     &        form='formatted',status='old')
      do j = 1,nggr2
         do i = 1,ntgr2
            read(24,*)wtgr(i),wggr(j),(wubv(i,j,k),k=1,5)
         enddo
      enddo
      do i = 1,ntgr2
         wtgr(i) = log10(wtgr(i))
      enddo
      CLOSE(24)
*
      RETURN
      END
***
      subroutine lt2ubv(logl,logt,mass,logz,bolc,mv,uminb,bminv,vmini)
      implicit none
c.... computes values of Mv, U-B, B-V and V-I for given log L, log T,
c.... mass and log(Z/0.02)
*
      integer k,ig,it,iz
      integer nzgr,ntgr,nggr
      parameter(nzgr=8,ntgr=61,nggr=11)
      integer indx
      external indx
      real*8 zgr(nzgr),tgr(ntgr),ggr(nggr),ubv(nzgr,ntgr,nggr,5)
      common /ubvdata/ zgr,tgr,ggr,ubv
      real*8 cm(5),gconst
      parameter(gconst=-10.6071d0)
      real*8 logl,logt,mass,logz,mv,uminb,bminv,vmini
      real*8 logm,logg,dg1,dg2,dt1,dt2,dz1,dz2,mbol,bolc
*
      logm = dlog10(mass)
      logg = logm + 4.d0*logt - logl + gconst
c.... find indices of log Z, log g and log T to interpolate between.
c.... don't allow extrapolation outside log Z and log g grid.
      ig = indx(logg,ggr,nggr)
      it = indx(logt,tgr,ntgr)
      iz = indx(logz,zgr,nzgr)
      dg1 = (logg - ggr(ig-1))/(ggr(ig) - ggr(ig-1))
      dg1 = max(0.d0, min(1.d0, dg1))
      dg2 = 1.d0 - dg1
      dt1 = (logt - tgr(it-1))/(tgr(it) - tgr(it-1))
      dt2 = 1.d0 - dt1
      dz1 = (logz - zgr(iz-1))/(zgr(iz) - zgr(iz-1))
      dz1 = max(0.d0, min(1.d0, dz1))
      dz2 = 1.d0 - dz1
      do k = 1, 5
         cm(k) = ((ubv(iz,it,ig,k)*dg1 + ubv(iz,it,ig-1,k)*dg2)*dt1
     &            + (ubv(iz,it-1,ig,k)*dg1 +
     &            ubv(iz,it-1,ig-1,k)*dg2)*dt2)*dz1 +
     &           ((ubv(iz-1,it,ig,k)*dg1 +
     &            ubv(iz-1,it,ig-1,k)*dg2)*dt1 +
     &           (ubv(iz-1,it-1,ig,k)*dg1 +
     &            ubv(iz-1,it-1,ig-1,k)*dg2)*dt2)*dz2
      enddo
      mbol = 4.75d0 - 2.5d0*logl
      bolc = cm(1)
      mv = mbol - bolc
      uminb = cm(2)
      bminv = cm(3)
      vmini = cm(4) + cm(5)
*
      return
      end
***
      integer function indx(ax,xx,nx)
c.....finds index of ax in monotonously increasing or decreasing array xx
      implicit none
      integer nx,j,jl,jh
      real*8 ax,xx(nx),sx
*
      sx = xx(nx) - xx(1)
      jl = 1
      jh = nx
 1    if (jh-jl.gt.1) then
         j = (jh + jl)/2
         if ((ax-xx(j))*sx.gt.0.d0) then
            jl = j
         else
            jh = j
         end if
         goto 1
      end if
      indx = jh
*
      return
      end
***
      subroutine wd2ubv(logl,logt,mass,bolc,mv,uminb,bminv,vmini)
c.... computes values of Mv, U-B, B-V and V-I for given log L, log T,
c.... mass and log(Z/0.02)
      implicit none
      integer k,ig,it
      integer ntgr,nggr
      parameter(ntgr=91,nggr=5)
      integer indx
      external indx
      real*8 tgr(ntgr),ggr(nggr),ubv(ntgr,nggr,5)
      common /wubvdata/ tgr,ggr,ubv
      real*8 cm(5),gconst
      parameter(gconst = -10.6071d0)
      real*8 mbol,bolc,mv,uminb,bminv,vmini
      real*8 logm,logg,dg1,dg2,dt1,dt2,mass,logt,logl
*
      logm = dlog10(mass)
      logg = logm + 4.d0*logt - logl + gconst
c.... find indices of log g and log T to interpolate between.
c.... don't allow extrapolation outside log g grid.
      ig = indx(logg,ggr,nggr)
      it = indx(logt,tgr,ntgr)
      dg1 = (logg - ggr(ig-1))/(ggr(ig) - ggr(ig-1))
      dg1 = MAX(0.d0,MIN(1.d0,dg1))
      dg2 = 1.d0 - dg1
      dt1 = (logt - tgr(it-1))/(tgr(it) - tgr(it-1))
      dt2 = 1.d0 - dt1
      do k = 1,5
         cm(k) = (ubv(it,ig,k)*dg1 + ubv(it,ig-1,k)*dg2)*dt1
     &         + (ubv(it-1,ig,k)*dg1 + ubv(it-1,ig-1,k)*dg2)*dt2
      enddo
      mbol = 4.75d0 - 2.5d0*logl
      bolc = cm(1)
      mv = mbol - bolc
      uminb = cm(2)
      bminv = cm(3)
      vmini = cm(4) + cm(5)
      return
      end
***


!->Module LIB_ROTVECT. Rafa Palacios. 07May2008-25May2011
!
!->Description.-
!
!  This module defines functions to operate with Cartesian Rotation
!  Vector (CRV) on finite rotations.
!
!-> List of functions:
!
!   rotvect_bounds:     Redefine a CRV for its norm to be within [-pi,pi].
!   rotvect_addpsi:     Compose rotations given by CRV.
!   rotvect_addquat:    Compose rotations given by quaternions.
!   rotvect_deltapsi:   Substract two Cartesian rotation vectors.
!   rotvect_lintpsi:    Interpolate CRV through linint of quaternions.
!   rotvect_lintquat:   Linear interpolation of quaternions.
!
!   rotvect_psi2theta:  Transform CRV to Rodrigues parameters.
!   rotvect_theta2psi:  Transform Rodrigues parameters to CRV.
!   rotvect_psi2quat:   Transform CRV to quaternions.
!   rotvect_quat2psi:   Transform quaternions to CRV.
!   rotvect_mat2quat:   Transform coordinate transf matrix to quaternions.
!   rotvect_psi2mat:    Transform CRV to the coordinate transf matrix.
!   rotvect_mat2psi:    Transform coordinate transf matrix to CRV.
!   rotvect_psi2rot:    Compute rotational operator for a CRV.
!   rotvect_psi2intmat: Transform CRV to the integral of the rotation matrix.
!
!   rotvect_drotdpsib:  Derivative of the rotational operator with the CRV.
!   rotvect_ddrotdpsib: Derivative of the time/space derivative of rot with the CRV.
!   rotvect_a1:         A1 operator (delta(T)*b=a1(Psi,b)*Delta(Psi))
!   rotvect_a2:         A2 operator (A2(Psi,b)=-A1(-Psi,b))
!   rotvect_b1:         B1 operator.
!   rotvect_b2:         B2 operator.
!
!-> Remarks.
!
!   1) The rotation vector is defined between -180 and +180 degrees. For
!      angles beyond this limits, it is mapped into this range. Note that
!      the discontinuity needs to be considered in later operations with
!      rotations.
!
!-> History.
!   25.05.2011: Review to set bounds on the CRV.
!               Added bounds deltapsi lintpsi lintquat
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
module lib_rotvect
 use lib_rot
 implicit none
!
!   (There are no public variables in this module).
!
!-> Private Variables.
!
  real(8),private, parameter :: pi=4.d0*atan(1.d0)
  real(8),private,parameter,dimension(3,3) :: Unit= &
&       reshape((/1.d0,0.d0,0.d0,0.d0,1.d0,0.d0,0.d0,0.d0,1.d0/),(/3,3/))

 contains

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Function ROTVECT_BOUNDS.
!
!->Description.-
!
!   Obtain the norm of the the Cartesian Rotation Vector and force the vector
!   to be in the [-pi,pi] interval.
!
!->Remarks.-
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 subroutine rotvect_bounds (Psi)

! I/O Variables.
  real(8),intent(inout)   :: Psi(3)

! Local variables.
  real(8):: OldNormPsi   ! Original norm of the CRV.
  real(8):: NormPsi      ! New norm within bounds.

! Compute original norm.
  OldNormPsi=sqrt(dot_product(Psi,Psi))

! Force the norm to be in [-pi,pi].
  NormPsi=OldNormPsi-2.d0*pi*int(OldNormPsi/(2.d0*pi))
  if (abs(NormPsi) <= rot_epsilon) then
    Psi=0.d0
  else
    if (NormPsi.gt.pi) then
      NormPsi=NormPsi - 2.d0*pi
    elseif (NormPsi.le.-pi) then
      NormPsi=NormPsi + 2.d0*pi
    end if
    Psi=Psi*(NormPsi/OldNormPsi)
  end if
 end subroutine rotvect_bounds

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Function ROTVECT_BOUNDSCHECK2.
!
!->Description.-
!
!   Check if two rotations are on both sides of the -pi / pi discontinuity and
!   add 2pi to one of them.
!
!->Remarks.-
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 subroutine rotvect_boundscheck2 (PsiA,PsiB)

! I/O Variables.
  real(8),intent(inout):: PsiA (3)
  real(8),intent(in)   :: PsiB (3)

! Local variables.
  real(8)              :: Norm

! Initialize
  Norm=sqrt(dot_product(PsiA,PsiA))

  ! if (Norm.ne.0.d0) then
  if (Norm > rot_Epsilon) then
! Check if the closest "distance" from the first to the second vector is obtained
! by adding or substracting 2*pi. This should remove the discontinuity at +/- pi,
! but needs some extensive checking.
    if (dot_product(PsiB-PsiA*(Norm+2.d0*pi)/Norm,PsiB-PsiA*(Norm+2.d0*pi)/Norm).lt.pi*pi) then
      PsiA = PsiA*(Norm+2.d0*pi)/Norm
    else if (dot_product(PsiB-PsiA*(Norm-2.d0*pi)/Norm,PsiB-PsiA*(Norm-2.d0*pi)/Norm).lt.pi*pi) then
      PsiA = PsiA*(Norm-2.d0*pi)/Norm
    end if
  end if
 end subroutine rotvect_boundscheck2

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Function ROTVECT_ADDPSI.
!
!->Description.-
!
!   Compose two rotations given by Cartesian Rotation vectors (right rotation).
!
!->Remarks.-
!  1) The second rotation is given with reference on the first one (a right
!     rotation).
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
function rotvect_addpsi (Psi01, Psi12) result(Psi)

! I/O Variables.
  real(8),intent(in)   :: Psi01 (3)
  real(8),intent(in)   :: Psi12 (3)

! Local variables.
  real(8),dimension(4) :: Quat01,Quat12,Quat02  ! Quaternions.
  real(8),dimension(3) :: Psi                   ! CRV.

  ! print*, Psi01
  ! print*, Psi12
! Transform to quaternions, add them, and convert the result back.
  Quat01=rotvect_psi2quat(Psi01)
  Quat12=rotvect_psi2quat(Psi12)

  Quat02=rotvect_addquat(Quat01,Quat12)

  Psi=rotvect_quat2psi(Quat02)
  call rotvect_bounds(Psi)
  ! call backtrace()
  ! read(*,*)
 end function rotvect_addpsi

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Function ROTVECT_ADDQUAT.
!
!->Description.-
!
!   Compose two rotations defined by quaternions.
!
!->Remarks.-
!  1) The second rotation is given with reference on the first one, which
!     corresponds to a right rotation.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 pure function rotvect_addquat (Quat01, Quat12)

! I/O Variables.
  real(8),intent(in)   :: Quat01 (4)
  real(8),intent(in)   :: Quat12 (4)
  real(8),dimension(4) :: rotvect_addquat ! Composed rotation (Quat02)

! Local variables.
  real(8),dimension(4,4):: B              ! B matrix.

! Define the B matrix based on the right rotation (Quat12)
  B = 0.0d0
  B(1,1)     = Quat12(1)
  B(1,2:4)   =-Quat12(2:4)
  B(2:4,1)   = Quat12(2:4)
  B(2:4,2:4) = Quat12(1)*Unit - rot_skew(Quat12(2:4))

! Compute composite rotation.
  rotvect_addquat=matmul(B,Quat01)
 end function rotvect_addquat

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Function ROTVECT_DELTAPSI.
!
!->Description.-
!
!  Substract two Cartesian rotation vectors (PsiB-PsiA).
!
!->Remarks.-
!
!   1) This routine simple checks that the two vectors don't lie on both sides
!      of the +/- pi discontinuity.
!
!   2) It needs further work to ensure "objectivity" (invariance in the evaluation
!      of derivatives of the CRV with rigid-body rotations of the global system.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
pure function rotvect_deltapsi (PsiA, PsiB) result(DeltaPsi)

! I/O Variables.
  real(8),intent(in)   :: PsiA (3)
  real(8),intent(in)   :: PsiB (3)
! Local variables.
  real(8),dimension(3) :: DeltaPsi       ! Increment between both CRVs.
  real(8)              :: Norm

! Initialize
  Norm=sqrt(dot_product(PsiB,PsiB))
! Transform to quaternions. Check if the closest "distance" from the first to the second
! vector is obtained by adding or substracting the 2*pi. In FEM applications this should
! remove the discontinuity at +/- pi, but needs some extensive checking.
  DeltaPsi = 0.0d0
  if (dot_product(PsiB*(Norm+2.d0*pi)/Norm-PsiA,PsiB*(Norm+2.d0*pi)/Norm-PsiA).lt.Pi*Pi) then
    DeltaPsi = PsiB*(Norm+2.d0*pi)/Norm - PsiA
  else if (dot_product(PsiB*(Norm-2.d0*pi)/Norm-PsiA,PsiB*(Norm-2.d0*pi)/Norm-PsiA).lt.Pi*pi) then
    DeltaPsi = PsiB*(Norm-2.d0*pi)/Norm - PsiA
  else
    DeltaPsi = PsiB - PsiA
  end if
 end function rotvect_deltapsi

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Function ROTVECT_LINTPSI.
!
!->Description.-
!
!   Interpolation of Cartesian Rotation vectors using linear interpolation of
!   the quaternions.
!
!->Remarks.-
!
!   1) The approach needs to be reviewed for cases where the two quaternions
!      go over the discontinuity at +/- pi. (RPN 25.05.2011)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! function rotvect_lintpsi (PsiA, PsiB, eta) result(PsiC)
!
!! I/O Variables.
!  real(8),intent(in)   :: PsiA (:)
!  real(8),intent(in)   :: PsiB (:)
!  real(8),intent(in)   :: eta                ! Eta between 0 and 1.
!
!! Local variables.
!  real(8),dimension(4) :: QuatA,QuatB,QuatC     ! Quaternions.
!  real(8),dimension(3) :: PsiC                  ! CRV at the interpolation point.
!  real(8)              :: Norm
!
!! Initialize
!  Norm=sqrt(dot_product(PsiB,PsiB))
!
!! Transform to quaternions. Check if the closest "distance" from the first to the second
!! vector is obtained by adding or substracting the 2*pi. In FEM applications this should
!! remove the discontinuity at +/- pi, but needs some extensive checking.
!  QuatA=rotvect_psi2quat(PsiA)
!  if (dot_product(PsiB*(Norm+2.d0*pi)/Norm-PsiA,PsiB*(Norm+2.d0*pi)/Norm-PsiA).lt.Pi*Pi) then
!    QuatB=rotvect_psi2quat(PsiB*(Norm+2.d0*pi)/Norm)
!  else if (dot_product(PsiB*(Norm-2.d0*pi)/Norm-PsiA,PsiB*(Norm-2.d0*pi)/Norm-PsiA).lt.Pi*pi) then
!    QuatB=rotvect_psi2quat(PsiB*(Norm-2.d0*pi)/Norm)
!  else
!    QuatB=rotvect_psi2quat(PsiB)
!  end if
!
!  QuatC=rotvect_lintquat(QuatA,QuatB,eta)
!
!! Transform back to CRV and force results within [-pi,+pi]
!  PsiC=rotvect_quat2psi(QuatC)
!  call rotvect_bounds (PsiC)
!  return
! end function rotvect_lintpsi

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Function ROTVECT_LINTQUAT.
!
!->Description.-
!
!   Linear interpolation of quaternions using the SLERP algorithm.
!
!->Remarks.-
!
!  1) See A.J. Hanson, "Visualizing quaternions", page 307.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! pure function rotvect_lintquat (QuatA, QuatB, eta)
!
! ! I/O Variables.
!   real(8),intent(in)   :: QuatA (:)
!   real(8),intent(in)   :: QuatB (:)
!   real(8),intent(in)   :: eta              ! Interpolation param, between 0 and 1.
!   real(8),dimension(4) :: rotvect_lintquat ! Interpolated rotation.
!
! ! Local variables.
!   real(8):: QuatC(4)
!   real(8):: Phi
!
! ! Minimum angle between A and B.
!   Phi=acos(dot_product(QuatA,QuatB))
!
! ! Compute interpolated rotation.
!   if (abs(Phi).lt.rot_Epsilon) then
!     QuatC=(1.d0-eta)*QuatA + eta*QuatB
!   else
!     QuatC=(sin((1.d0-eta)*Phi)/sin(Phi))*QuatA + &
! &         (sin(      eta *Phi)/sin(Phi))*QuatB
!   end if
!
! ! Enforce unit norm.
!   rotvect_lintquat =QuatC/sqrt(dot_product(QuatC,QuatC))
!
!   return
!  end function rotvect_lintquat

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Function ROTVECT_PSI2THETA.
!
!->Description.-
!
!   Transform a rotation vector to the corresponding Rodrigues parameters.
!
!-> Remarks.-
!
!   1) It returns an error when Theta~=pi.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
function rotvect_psi2theta (Psi)
! I/O Variables.
  real(8),intent(in)  :: Psi(3)             ! Rotation Vector.
  real(8),dimension(3):: rotvect_psi2theta  ! Rodrigues Parameters.

! Local variables
  real(8):: NormPsi                         ! Norm of the Rotation Vector.

! Compute normal vector.
  NormPsi=sqrt(dot_product(Psi,Psi))

! The evaluation of the parameters depends on the magnitude of the rotation
! vector.
  if (abs(NormPsi).le.rot_Epsilon) then
    rotvect_psi2theta=Psi
  else if (abs(NormPsi-pi).le.rot_EpsilonMin) then
      STOP 'Error in rotvec_psi2theta'
  else
    rotvect_psi2theta= (tan(NormPsi*0.5d0)/(NormPsi*0.5d0))*Psi
  end if
 end function rotvect_psi2theta

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Function ROTVECT_THETA2PSI.
!
!->Description.-
!
!   Converts a vector of Rodrigues parameters into the corresponding Cartesian
!   rotation vector.
!
!-> Remarks.-
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 function rotvect_theta2psi (Theta) result(Psi)

! I/O Variables.
  real(8),intent(in)  :: Theta(:)       ! Rodrigues Parameters.

! Local variables
  real(8):: NormTheta      ! Norm of Theta.
  real(8):: Normal(3)      ! Unit normal vector to the rotation plane.
  real(8):: Psi   (3)      ! CRV
  real(8):: NormPsi        ! Norm of the CRV

  NormPsi = 0.d0    ! Rob: stops normpsi uninitialized warning flag.
                    ! Rob: the if statement below makes no sense.

! Compute normal vector.
  NormTheta=dsqrt(dot_product(Theta,Theta))
  if (abs(NormPsi).le.rot_Epsilon) then
    Normal=0.d0
  else
    Normal=Theta/NormPsi
  end if

! Compute rotation vector.
  Psi= 2.d0*atan(NormTheta*0.5d0)*Normal

! Force bounds on the CRV
  call rotvect_bounds(Psi)
  return
 end function rotvect_theta2psi

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Function ROTVECT_PSI2QUAT.
!
!->Description.-
!
!   Transform a rotation vector to the corresponding quaternions.
!
!-> Remarks.-
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 pure function rotvect_psi2quat (Psi)

! I/O Variables.
  real(8),intent(in)  :: Psi(3)            ! Rotation Vector.
  real(8),dimension(4):: rotvect_psi2quat  ! Quaternions.

! Local variables
  real(8):: NormPsi        ! Norm of the Rotation Vector.

! Compute the norm.
  NormPsi=sqrt(dot_product(Psi,Psi))

! Transform rotation vector to quaternions.
  rotvect_psi2quat(1)  = cos(NormPsi*0.5d0)

! Small angles approximation.
  if (abs(NormPsi).lt.rot_Epsilon) then
    rotvect_psi2quat(2:4)=(0.5d0-NormPsi*NormPsi/12.d0)*Psi
! Regular expression.
  else
    rotvect_psi2quat(2:4)=(sin(NormPsi*0.5d0)/NormPsi)*Psi
  end if
 end function rotvect_psi2quat

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Function ROTVECT_QUAT2PSI.
!
!->Description.-
!
!   Transform quaternions to the corresponding rotation vector.
!
!-> Remarks.-
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 function rotvect_quat2psi (Quat) result(Psi)

! I/O Variables.
  real(8),intent(in)  :: Quat(4)            ! Quaternions.

! Local variables
  real(8):: NormPsi      ! Norm of the Rotation Vector.
  real(8):: Psi(3)       ! CRV

! Compute rotation angle (norm of the rotation vector). It is bounded in [0,2*pi].
  NormPsi = 2.d0 * acos(max(-1.d0,min(Quat(1),1.d0)))

! Compute normal vector.
  if (abs(NormPsi) < rot_Epsilon) then
    Psi=0.d0
  else
    Psi=NormPsi*Quat(2:4)/sin(NormPsi*0.5d0)
  end if

! Set bounds in [-pi,pi].
  call rotvect_bounds (Psi)
 end function rotvect_quat2psi

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Function ROTVECT_MAT2QUAT.
!
!->Description.-
!
!   Transform coordinate transformation matrix into quaternions form.
!
!-> Remarks.-
!
!   1) It uses the algorithm described in (Geradin & Cardona, 2001).
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 pure function rotvect_mat2quat (CoordTransMat) result(Quat)

! I/O Variables.
  real(8),intent(in)  :: CoordTransMat(3,3)   ! Quaternions.

! Local variables
  integer:: i             ! Counter.
  integer:: iMax          ! Index of SMax.
  real(8):: Quat(4)       ! Quaternions to be computed.
  real(8):: SMax          ! Max in the diagonal of S.
  real(8):: S(4,4)        ! Intermediate matrix.
  real(8):: R(3,3)        ! Rotation matrix corresponding to CoordTransMat.

! Transpose to use standard expressions.
  R=transpose(CoordTransMat)

  S = 0.0d0
! Intermediate matrix S (see Geradin & Cardona, 2001)
  S(1,1)=1.d0+R(1,1)+R(2,2)+R(3,3)
  S(1,2)=R(3,2)-R(2,3)
  S(1,3)=R(1,3)-R(3,1)
  S(1,4)=R(2,1)-R(1,2)

  S(2,1)=R(3,2)-R(2,3)
  S(2,2)=1.d0+R(1,1)-R(2,2)-R(3,3)
  S(2,3)=R(1,2)+R(2,1)
  S(2,4)=R(1,3)+R(3,1)

  S(3,1)=R(1,3)-R(3,1)
  S(3,2)=R(2,1)+R(1,2)
  S(3,3)=1.d0-R(1,1)+R(2,2)-R(3,3)
  S(3,4)=R(2,3)+R(3,2)

  S(4,1)=R(2,1)-R(1,2)
  S(4,2)=R(1,3)+R(3,1)
  S(4,3)=R(2,3)+R(3,2)
  S(4,4)=1.d0-R(1,1)-R(2,2)+R(3,3)

! Find maximum term in diagonal.
imax = 0
  SMax=0.d0
  do i=1,4
    if (S(i,i).ge.SMax) then
      iMax=i
      SMax=S(i,i)
    end if
  end do

  Quat = 0.0d0
! Compute quaternion angles.
  Quat(iMax)=0.5d0*sqrt(SMax)
  do i=1,4
    if (i.ne.iMax) Quat(i)=0.25d0*S(iMax,i)/Quat(iMax)
  end do
 end function rotvect_mat2quat

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Function ROTVECT_PSI2MAT.
!
!->Description.-
!
!   Transform a rotation vector to the corresponding coordinate transformation
!   matrix (transpose of the rotation matrix).
!
!   Returns Cba
!
!-> Remarks.-
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 function rotvect_psi2mat (Psi)
! I/O Variables.
  real(8),intent(in)    :: Psi(3)           ! Rotation Vector.
  real(8),dimension(3,3):: rotvect_psi2mat  ! Coord transf matrix.

! Local variables
  real(8):: NormPsi        ! Norm of the Rotation Vector.
  real(8):: RotMatrix(3,3) ! Rotation Matrix.
  real(8):: SkewNormal(3,3)! Skew-symmetric form of the normal vector.
  real(8):: SkewPsi(3,3)   ! Skew-symmetric form of the CRV.

! Compute norm.
  NormPsi=sqrt(dot_product(Psi,Psi))

! Small angles.
  if (abs(NormPsi).le.rot_Epsilon) then
    SkewPsi=rot_skew(Psi)
    RotMatrix= Unit + SkewPsi + 0.5d0*matmul(SkewPsi,SkewPsi)
! Larger angles.
  else
    SkewNormal=rot_skew(Psi/NormPsi)
    RotMatrix= Unit + sin(NormPsi)*SkewNormal               &
&            + (1.d0 - cos(NormPsi))*matmul(SkewNormal,SkewNormal)
  end if

! The rotation matrix is the transpose of the coordinate transformation matrix.
  rotvect_psi2mat=transpose(RotMatrix)
 end function rotvect_psi2mat

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Function ROTVECT_MAT2PSI.
!
!->Description.-
!
!   Transform coordinate transformation matrix into Cartesian rotation vector.
!
!-> Remarks.-
!
!  1) Quaternions are used as intermediate step. This is very efficient for large
!     rotations, but it yields zero for rotations below 1d-8 due to round-off
!     errors. It would be better in those cases to use the linear form of the
!     matrix.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
function rotvect_mat2psi (CoordTransMat) result(Psi)

! I/O Variables.
  real(8),intent(in)  :: CoordTransMat(3,3) ! Coordinate transformation matrix.

! Local variables.
  real(8),dimension(3):: Psi                ! Cartesian rotation matrix.

! Rotation Matrix -> Quaternions -> Cartesian rotation vector.
Psi= rotvect_quat2psi(rotvect_mat2quat(CoordTransMat))
! For very small rotations, the normal formula fails.
  if (abs(dot_product(Psi,Psi)).le.rot_Epsilon) then
    Psi(1)= CoordTransMat(2,3)
    Psi(2)= CoordTransMat(3,1)
    Psi(3)= CoordTransMat(1,2)
  end if

! Set bounds between [-pi,pi] and return the CRV.
  call rotvect_bounds (Psi)
  return
 end function rotvect_mat2psi

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Function ROTVECT_PSI2ROT.
!
!->Description.-
!
!   Obtain rotational (tangential) operator from Cartesian rotation vector.
!
!-> Remarks.-
!
!   1) The cartesian rotation vector from 1 to 2 (alpha_1^2) corresponds to the
!      coordinate transformation matrix from 1 to 2: C^2^1.
!
!      A vector given in its components in the base 1 (u_1), is expressed in its
!      components in a base 2 (u_2) as
!
!                  u_2= C^2^1*u_1
!
!  2) Equation (4.11) of (Cardona and Geradin, 2001).
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 function rotvect_psi2rot (Psi)

! I/O Variables.
  real(8),intent(in)    :: Psi(3)            ! Cartesian rotation vector.
  real(8),dimension(3,3):: rotvect_psi2rot   ! Rotational operator.

! Local variables
  real(8):: K1,K2           ! Auxiliary variables.
  real(8):: NormPsi         ! Norm of Psi.
  real(8):: PsiSkew(3,3)    ! Skew-symmetric form of psi.

! Compute rotation angle.
  NormPsi= sqrt(dot_product(Psi,Psi))
  PsiSkew= rot_skew(Psi)

! For small angles, use the linear approximation
  if (abs(NormPsi).le.rot_Epsilon) then
    K1=1.d0
    K2=1.d0/6.d0
    rotvect_psi2rot= Unit - (0.5d0*K1)*PsiSkew + K2*matmul(PsiSkew,PsiSkew)
  else
      k1 = (cos(normpsi) - 1.0)/(normpsi*normpsi)
      k2 = (1.0 - sin(normpsi)/normpsi)/(normpsi*normpsi)
      rotvect_psi2rot = Unit + k1*psiskew + k2*matmul(psiskew, psiskew)
  end if

 end function rotvect_psi2rot

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Function ROTVECT_PSI2INTMAT.
!
!->Description.-
!
!   Transform a rotation vector to the integral of the rotation matrix for
!   an element of lenght 1.
!
!-> Remarks.-
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 pure function rotvect_psi2intmat (Psi)
! I/O Variables.
  real(8),intent(in)    :: Psi(3)              ! Rotation Vector.
  real(8),dimension(3,3):: rotvect_psi2intmat  ! Integral of coord transf matrix.

! Local variables
  real(8):: NormPsi        ! Norm of the Rotation Vector.
  real(8):: RotInt(3,3)    ! Integral of Rotation Matrix.
  real(8):: SkewPsi(3,3)   ! Skew-symmetric form of the CRV.

! Compute norm.
  NormPsi= sqrt(dot_product(Psi,Psi))
  SkewPsi= rot_skew(Psi)

! Small angles.
  if (abs(NormPsi).le.rot_Epsilon) then
    RotInt= Unit + 0.5d0*SkewPsi + (1.d0/6.d0)*matmul(SkewPsi,SkewPsi)

! Larger angles.
  else
    RotInt= Unit + ((1.d0-cos(NormPsi))/(NormPsi*NormPsi))*SkewPsi     &
&                + ((NormPsi-sin(NormPsi))/(NormPsi*NormPsi*NormPsi))  &
&                  *matmul(SkewPsi,SkewPsi)
  end if

! The rotation matrix is the transpose of the coordinate transformation matrix.
  rotvect_psi2intmat=transpose(RotInt)
  return
 end function rotvect_psi2intmat

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Function ROTVECT_DROTDPSIB.
!
!->Description.-
!
!   Compute the derivative of the tangential operator with the rotation vector
!   and multiply the result by a given vector, i.e., (dT/dPsi_i)*b_i
!
!-> Remarks.-
!
!   1) dT/dPsi is a third-order tensor. The first two indexes are the rows
!      and columns of the T matrix, while the third index goes along the
!      dimensions of the Rotation vector. Vector b multiplies that third
!      dimension.
!   2) If b=Psi', the output is T'(Psi).
!   3) If b=PsiDot, the output is Tdot(Psi).
!   4) Note that droptdpsib(Psi,psiDot)*b= A1(Psi,b)*PsiDot, but A1 is not
!      the same as this function.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 pure function rotvect_drotdpsib (Psi,b)

! I/O Variables.
  real(8),intent(in)    :: Psi(3)              ! Cartesian rotation vector.
  real(8),intent(in)    :: b(3)                ! Input Vector.
  real(8),dimension(3,3):: rotvect_drotdpsib   ! (dT/dPsi)*b

! Local variables
  real(8):: K1,K2           ! Auxiliary variables.
  real(8):: bSkew(3,3)      ! Skew-symmetric form of b.
  real(8):: NormalSkew(3,3) ! Skew-symmetric form of normal vector.
  real(8):: Normal(3)       ! Unit normal vector to the rotation plane.
  real(8):: NormPsi         ! Norm of Psi.
  real(8):: PsiSkew(3,3)    ! Skew-symmetric form of psi.

! Compute rotation angle.
  NormPsi=sqrt(dot_product(Psi,Psi))
  bSkew=rot_skew(b)

! For small angles, use the linear approximation
  if (abs(NormPsi).le.rot_Epsilon) then
    PsiSkew=rot_skew(Psi)
    rotvect_drotdpsib= &
&     -0.5d0*bSkew + (1.d0/6.d0)*(matmul(PsiSkew,bSkew)+matmul(bSkew,PsiSkew))
! For larger angles.
  else
    Normal=Psi/NormPsi
    NormalSkew=rot_skew(Normal)
    K1= (1.d0 - cos(NormPsi))/(NormPsi*NormPsi)
    K2= sin(NormPsi)/NormPsi

    rotvect_drotdpsib= &
&        (2.d0*K1-K2)*dot_product(b,Normal) * NormalSkew - K1*bSkew              &
&      + ((3.d0*K2-2.d0-dcos(NormPsi))/NormPsi) * dot_product(b,Normal)           &
&                                              * matmul(NormalSkew,NormalSkew)   &
&      + ((1.d0-K2)/NormPsi) * (matmul(NormalSkew,bSkew)+matmul(bSkew,NormalSkew))
  end if
 end function rotvect_drotdpsib

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Function ROTVECT_DDROTDPSIB.
!
!->Description.-
!
!  Compute the derivative of the time or spatial derivative of the tangential
!  operator with the rotation vector and multiply the result by a given vector,
!  i.e., (dT'/dPsi)*b
!
!-> Remarks.-
!
!   1) dT'/dPsi is a third-order tensor. The first two indexes are the rows
!      and columns of the T' (or Tdot) matrix, while the third index goes along
!      the dimensions of the Rotation vector.
!
!   2) If b=Psi', the output is part of T"(Psi). T" is obtained as
!      T"=ddrotdpsib(Psi,PsiDot,PsiDot)+drotdpsib(Psi,PsiDotDot)
!
!   3) If b=PsiDot, the output is part of Tdotdot(Psi).
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 pure function rotvect_ddrotdpsib (Psi,PsiDot,b)

! I/O Variables.
  real(8),intent(in)    :: Psi(3)              ! Cartesian rotation vector.
  real(8),intent(in)    :: PsiDot(3)           ! Derivative of CRV.
  real(8),intent(in)    :: b(3)                ! Input Vector.
  real(8),dimension(3,3):: rotvect_ddrotdpsib  ! (dT'/dPsi)*b

! Local variables
  real(8):: bS(3,3)         ! Skew-symmetric form of b.
  real(8):: nS(3,3)         ! Skew-symmetric form of normal vector.
  real(8):: Normal(3)       ! Unit normal vector to the rotation plane.
  real(8):: NormPsi         ! Norm of Psi.
  real(8):: p1S(3,3)        ! Skew-symmetric form of PsiDot.
  real(8):: pS(3,3)         ! Skew-symmetric form of Psi.

  real(8):: C1,C2           ! Auxiliary variables.
  real(8):: K0,K1,K2
  real(8):: dnb,dnp1,dbp1

! Compute rotation angle.
  NormPsi=sqrt(dot_product(Psi,Psi))

  bS  = rot_skew(b)
  pS  = rot_Skew(Psi)
  p1S = rot_skew(PsiDot)

! For small angles, use the linear approximation
  if (abs(NormPsi).le.rot_Epsilon) then
    rotvect_ddrotdpsib=                                      &
&               (1.d0/6.d0)*(matmul(bs,p1S)+matmul(p1S,bs))  &
&             + (dot_product(PsiDot,b)  /12.d0)*pS           &
&             + (dot_product(PsiDot,Psi)/12.d0)*bs           &
&             + (dot_product(Psi   ,b)  /12.d0)*p1S

! For larger angles.
  else
    Normal=Psi/NormPsi
    nS    =rot_skew(Normal)

    C1= 1.d0/NormPsi
    C2= C1*C1

    K0= cos(NormPsi)
    K1= (1.d0-K0)/(NormPsi*NormPsi)
    K2= sin(NormPsi)/NormPsi

    dnp1= dot_product(Normal,PsiDot)
    dnb = dot_product(Normal,b)
    dbp1= dot_product(b,PsiDot)

    rotvect_ddrotdpsib=                                        &
              - C1*(K0+8.d0*K1-5.d0*K2)*dnb*dnp1*nS            &
&             + C1*(2.d0*K1-K2)*(dbp1*nS+dnp1*bS+dnb*p1S)      &
&             - C2*((15.d0-NormPsi*NormPsi)*K2-8.d0-7.d0*K0)   &
&                 *dnb*dnp1*matmul(nS,nS)                      &
&             + C2*(3.d0*K2-2.d0-K0)                           &
&                 *( dbp1*matmul(nS,nS)+dnp1*matmul(bS,nS)     &
&                  + dnp1*matmul(nS,bS)+ dnb*matmul(nS,p1S)    &
&                  + dnb *matmul(p1S,nS))                      &
&             + C2*(1.d0-K2)*(matmul(bS,p1S)+matmul(p1S,bS))
  end if
 end function rotvect_ddrotdpsib

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Function ROTVECT_A1.
!
!->Description.-
!
!   A1 operator on the tangential operator.
!
!-> Remarks.-
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 pure function rotvect_a1 (Psi,b)
! I/O Variables.
  real(8),intent(in)    :: Psi(3)              ! Cartesian rotation vector.
  real(8),intent(in)    :: b(3)                ! Input Vector.
  real(8),dimension(3,3):: rotvect_a1          ! (dT/dPsi)*b

! Local variables
  real(8):: K1,K2           ! Auxiliary variables.
  real(8):: bSkew(3,3)      ! Skew-symmetric form of b.
  real(8):: NormalMat(3,3)  ! Outer product of N by itself.
  real(8):: NormalSkew(3,3) ! Skew-symmetric form of normal vector.
  real(8):: Normal(3)       ! Unit normal vector to the rotation plane.
  real(8):: NormPsi         ! Norm of Psi.
  real(8):: PsiSkew(3,3)    ! Skew-symmetric form of psi.

! Compute rotation angle.
  NormPsi=sqrt(dot_product(Psi,Psi))
  bSkew=rot_skew(b)

! For small angles, use the linear approximation
  if (abs(NormPsi).le.rot_Epsilon) then
    PsiSkew=rot_skew(Psi)
    rotvect_a1= 0.5d0*bSkew + (1.d0/6.d0)*matmul(bSkew,PsiSkew) &
&                           - (1.d0/3.d0)*matmul(PsiSkew,bSkew)

! For larger angles.
  else
    Normal=Psi/NormPsi
    NormalSkew=rot_skew(Normal)
    K1= (1.d0 - cos(NormPsi))/(NormPsi*NormPsi)
    K2= sin(NormPsi)/NormPsi
    NormalMat=rot_outprod(Normal,Normal)

    rotvect_a1=                                                           &
&       -(2.d0*K1-K2)*matmul(bSkew,NormalMat) + K1*bSkew                  &
&       -((3.d0*K2-2.d0-dcos(NormPsi))/NormPsi) * matmul(NormalSkew,      &
&                                                matmul(bSkew,NormalMat)) &
&       +((1.d0-K2)/NormPsi) * (      matmul(bSkew,NormalSkew)            &
&                               -2.d0*matmul(NormalSkew,bSkew))
  end if
 end function rotvect_a1

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Function ROTVECT_A2.
!
!->Description.-
!
!   A2 operator on the tangential operator.
!
!-> Remarks.-
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 pure function rotvect_a2 (Psi,b)
! I/O Variables.
  real(8),intent(in)    :: Psi(3)              ! Cartesian rotation vector.
  real(8),intent(in)    :: b(3)                ! Input Vector.
  real(8),dimension(3,3):: rotvect_a2          ! (dT/dPsi)*b

  rotvect_a2= -rotvect_a1(-Psi,b)
 end function rotvect_a2

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Function ROTVECT_B1.
!
!->Description.-
!
!   B1 operator on the tangential operator.
!
!-> Remarks.-
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 pure function rotvect_b1 (Psi,PsiDot,b)
! I/O Variables.
  real(8),intent(in)    :: Psi(3)              ! Cartesian rotation vector.
  real(8),intent(in)    :: PsiDot(3)           ! Derivative of Psi.
  real(8),intent(in)    :: b(3)                ! Input Vector.
  real(8),dimension(3,3):: rotvect_b1          ! (dTdot/dPsi)*b

! Local variables
  real(8):: bS(3,3)         ! Skew-symmetric form of b.
  real(8):: nS(3,3)         ! Skew-symmetric form of normal vector.
  real(8):: Normal(3)       ! Unit normal vector to the rotation plane.
  real(8):: NormPsi         ! Norm of Psi.
  real(8):: p1S(3,3)        ! Skew-symmetric form of PsiDot.

  real(8):: C1,C2           ! Auxiliary variables.
  real(8):: K0,K1,K2,K3
  real(8),dimension(3,3):: nnT,bSnnT,nSbSnnT,np1T,p1nT,nSp1S2bnT

! Compute rotation angle.
  NormPsi=sqrt(dot_product(Psi,Psi))

  bS  = rot_skew(b)
  p1S = rot_skew(PsiDot)

! For small angles, use the linear approximation
  if (abs(NormPsi).le.rot_Epsilon) then
    rotvect_b1= (1.d0/6.d0)*matmul(bS,p1S)                      &
&             - (1.d0/3.d0)*matmul(p1S,bS)                      &
&             - (1.d0/12.d0)*matmul(bS,rot_outprod(Psi,PsiDot)  &
&                                     +rot_outprod(PsiDot,Psi)) &
&             - (1.d0/12.d0)*dot_product(Psi,PsiDot)*bs

! For larger angles.
  else
    Normal=Psi/NormPsi
    nS    =rot_skew(Normal)

    C1= 1.d0/NormPsi
    C2= C1*C1

    K0= cos(NormPsi)
    K1= (1.d0-K0)/(NormPsi*NormPsi)
    K2= sin(NormPsi)/NormPsi
    K3= dot_product(Normal,PsiDot)

    nnT    = rot_outprod(Normal,Normal)
    bSnnT  = matmul(bS,nnT)
    nSbSnnT= matmul(nS,bSnnT)

    np1T   = rot_outprod(Normal,PsiDot)
    p1nT   = rot_outprod(PsiDot,Normal)
    nSp1S2bnT= matmul((matmul(nS, p1S) + matmul(p1S, nS)), &
&                     rot_outprod(b,Normal))

    rotvect_b1= C1*(K0+8.d0*K1-5.d0*K2)*K3*bSnnT                &
&             - C1*(2.d0*K1-K2)                                 &
&                 *(matmul(bS,np1T+p1nT)                        &
&                  +bs*dot_product(Normal,PsiDot))              &
&             + C2*((15.d0-NormPsi*NormPsi)*K2-8.d0-7.d0*K0)    &
&                 *K3*nSbSnnT                                   &
&             + C2*(3.d0*K2-2.d0-K0)                            &
&                 *(nSp1S2bnT-matmul(nS,matmul(bS,np1T))        &
&                   +K3*(matmul(bS,nS)-2.d0*matmul(nS,bS)))     &
&             + C2*(1.d0-K2)                                    &
&                 *(matmul(bS,p1S)-2.d0*matmul(p1S,bS))
  end if
 end function rotvect_b1

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Function ROTVECT_B2.
!
!->Description.-
!
!   B2 operator on the tangential operator.
!
!-> Remarks.-
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 pure function rotvect_b2 (Psi,PsiDot,b)
! I/O Variables.
  real(8),intent(in)    :: Psi(3)              ! Cartesian rotation vector.
  real(8),intent(in)    :: PsiDot(3)           ! Derivative of Psi.
  real(8),intent(in)    :: b(3)                ! Input Vector.
  real(8),dimension(3,3):: rotvect_b2          ! (dT/dPsi)*b

  rotvect_b2= rotvect_b1(-Psi,PsiDot,b)
 end function rotvect_b2

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
end module lib_rotvect


C
C $Id: haprin.f,v 1.4 2008-09-18 00:42:16 kennison Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE HAPRIN (UVAL,VVAL,DLAT,DLON)
C
        DOUBLE PRECISION UVAL,VVAL,DLAT,DLON
C
C The subroutine HAPRIN implements a closed form of the Hammer
C projection, using formulas given on "Wolfram MathWorld".
C
C UVAL and VVAL are input values of U and V, in the projection plane.
C DLAT and DLON are output values of latitude and longitude, in radians.
C
C The common block MAPCM0 contains mathematical constants.
C
        COMMON /MAPCM0/  COS1,DTOR,DTRH,OOPI,PI,PIOF,PIOT,RTDD,RTOD,
     +                   SROT,SIN1,TOPI,TSRT
        DOUBLE PRECISION COS1,DTOR,DTRH,OOPI,PI,PIOF,PIOT,RTDD,RTOD,
     +                   SROT,SIN1,TOPI,TSRT
        SAVE   /MAPCM0/
C
C Local variables.
C
        DOUBLE PRECISION SVAL,TVAL
C
C First, we must check the point (UVAL,VVAL) to see if it lies in the
C ellipse occupied by the projection of the globe.  If not, we return
C the value "1.D12" to signal that fact.
C
        IF ((UVAL/TSRT)**2+(VVAL/SROT)**2-1.D0.GT.1.D-12) THEN
          DLAT=1.D12
          DLON=1.D12
          RETURN
        END IF
C
C Do the math.
C
        SVAL=1.D0-.0625D0*UVAL**2-.25D0*VVAL**2
        TVAL=SQRT(SVAL)
C
        DLAT=ASIN(MAX(-1.D0,MIN(+1.D0,VVAL*TVAL)))
        DLON=2.D0*ATAN2(UVAL*TVAL,4.D0*SVAL-2.D0)
C
        RETURN
C
      END