!     Last change:  HO   27 May 2000   11:47 pm
!=============================================================================
MODULE crc
IMPLICIT NONE
PRIVATE
PUBLIC :: crc16
INTEGER, PARAMETER :: igenerator = Z'8005' !B'1000000000000101'  ! x^16+x^15+x^2+1
CONTAINS
!--------------------------------------------------------------------------
SUBROUTINE crc16(n, in, icrc)
IMPLICIT NONE
INTEGER, INTENT(IN    ) :: n, in
INTEGER, INTENT(IN OUT) :: icrc
INTEGER :: k, j, ibit1, ibit2
k = in
DO j = 1, n
 ibit1 = k * 2 / 2**n       !  nth bit
 k = MOD(k * 2, 2**n)
 ibit2 = icrc * 2 / 2**16   ! 16th bit
 icrc = MOD(icrc * 2, 2**16)
 IF(IEOR(ibit1, ibit2) == 1) icrc = IEOR(icrc, igenerator)
END DO
RETURN
END SUBROUTINE crc16
!--------------------------------------------------------------------------
END MODULE crc


program main
!==================================================================================
! Main program for testing the radiative transfer module
!==================================================================================

use radiation_mod

implicit none

real                :: pg0     = 1.0
real                :: zy      = 60.0
real                :: surfalb = 0.30
real                :: fco2, pco2, ptot, olr, palb, tg0
real, dimension(28) :: pco2levels

integer             :: temp, tstart=190, tend=370, tstep=1
integer             :: i

pco2levels = (/ 1.e-6,3.e-6,6.e-6,1.e-5, 3.e-5, 6.e-5,1.e-4, &
3.e-4, 6.e-4,1.e-3, 3.e-3, 6.e-3,1.e-2, 3.e-2, 6.e-2,1.e-1,  &
3.e-1, 6.e-1,1., 2., 3., 4., 5., 6., 7., 8., 9., 10. /)

call radiation_init

do temp = tstart, tend, tstep
  do i = 1, 28

    pco2 = pco2levels(i)

    ptot = pg0 + pco2
    fco2 = pco2 / ptot

    tg0 = real( temp )

    call getOLR( fco2, tg0, olr )
    !print *, olr / 1000.

    call getPALB( fco2, tg0, zy, surfalb, palb )
    print *, palb

  end do

end do

call radiation_end

end program main


c=======================================================================
c     subroutine BLRETURN
c
c     This function computes the expected return by the Black-Litterman
c     method
c
c     mu = inv(inv(taux*cov) + P'*inv(omega)*P)*(inv(alpha*cov)*rho + P'*inv(omega)*q);
c
c     mu    : expected returns
c     alpha : confidence on the equilibrium returns
c     cov   : covariance matrix
c     rho   : equilibrium returns = delta*cov*w
c     pview : matrix of investor views
c     omega : uncertainty view matrix
c     view  : investor views
c
c----------------------------------------------------------------------
      SUBROUTINE blreturn ( p, q, alpha, cov, rho, pview, omega, view,
     &                      iwork, dwork, mu, info )
c----------------------------------------------------------------------
c
c     INPUT
c       p     : portfolio size (p>1)                           integer
c       q     : number of view (q>0)                            double
c       alpha : confidence on the equilibrium returns           double
c       cov   : covariance matrix (p by p)                      double
c       rho   : equilibrium returns = delta*cov*w (p)           double
c       pview : matrix of investor views (q by p)               double
c       omega : uncertainty view matrix  (q by q)               double
c       view  : investor views (q)
c
c     WORKSPACES
c       iwork :                                                 double
c       dwork :                                                 double
c
c     OUTPUT
c       mu    : Black-Litterman estimator (p)                   double
c       info  : diagnostic argument                            integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER p, q, info
      DOUBLE PRECISION mu(*), rho(*), cov(*), pview(*), omega(*),
     &                 view(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER i, pdones, pdinvC, pdjms, pdv
      DOUBLE PRECISION x, y, t, w, EPS, ZERO, ONE
      PARAMETER ( EPS = 1.E-30, ZERO = 0.0, ONE = 1.0 )
c
c     external subroutines
      EXTERNAL PMX, JMS, OVTMCV
c
c-----------------------------------------------------------------------
c
c     initialization
      info = 0
      DO i = 1,p
        mu(i) = rho(i)
      ENDDO
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdjms  = 1
c     pdjms  : pointer for workspaces of JMS (p*p)
      pdinvC = pdjms + ( p*p )
c     pdinvC : pointer for inverse cov. matrix (p*p)
      pdones = pdinvC + ( p*p )
c     pdones : pointer for ones vector (p)
      pdv   = pdones + ( p )
c     pdv   : pointer for temporary vector
c
c     Total size of dwork array = 2*p*(p + 1)
c
c----------------------------------------------------------------------
c
c     alpha*cov
      CALL PMX ( p, p, cov, alpha, dwork(pdcov)) )
c
c     inv(alpha*cov)
      CALL JMS ( p, dwork(pdcov), dwork(pdjms), dwork(pdinvC), info )
      IF (info .NE. 0) THEN
        info = -108
        RETURN
      ENDIF
c
c     P'*inv(omega)*P
      CALL OVTMCV (p, dwork(pdinvC), dwork(pdones), y )
      IF (y .LT. EPS) THEN
        info = -1
        RETURN
      ENDIF
c     1'*inv(cov)*rho
c     matrix vector multiply: U(p) = A(p,p)*V(p)
      CALL PMV ( p, p, dwork(pdinvC), rho, dwork(pdv) )
      CALL SEV ( p, dwork(pdv), x )
c
      RETURN
      END


      double precision function exchee (d,dr)
      implicit double precision (a-h,o-z)
      save
c jm if density= 0,make exchange energy equal to zero
      if (d .eq. 0.0) then
      exchee=0.0
      else
      x=(3.0*dr**2/d)**.333333333333/30.0
      rx=1.0/x
      exchee=.02520*(x**3*log(1.0+rx)+x*.50-x**2-1.0/3.0-0.2020129
     1 2*rx)
      endif
      return
      end


subroutine  AIR (ZLS, YCOUNT)
  use simsphere_mod, only: hgt, gam, gm, het, heat, otemp, advgt, dens, cp, &
                           aptemp, atemp, tdif_50, delt, dhet, td, ntrp,    &
                           rad, grav, delta, za, ifirst, deltaz, eq
  implicit none

! **  Subroutine air computes the daytime height of the mixing layer and
! **  the potential temperature at height ZA.

  real :: ZLS(50)
  real :: CHGT = 0.0
  real :: CTHETA = 1.0
  real :: CDELT, DELTX, zmix, tdel, ttop, YCOUNT
  integer :: I, J, L

!      INCLUDE 'modvars.h'

  IFIRST = 1.0

! **  Signal daytime situation, IFIRST = 1.

! **  Select the correct Pot. Temp lapse rate.

  do J = 2 , 9
    IF ( HGT > ZLS(J - 1) ) GAM = GM(J)
  end do

! **  CHGT is calculated here once only, based initially on a parameter-
! **  isation of Tennekes, before passing onto the ELSE statement.  Now
! **  mitre the mixing layer loop to 24 sec to increase accuracy, calc
! **  pot temp, temp at ZA and the mixing layer height over 240 sec.

  IF ( eq(CHGT,0.0) ) THEN
    HET = HEAT / ( DENS * CP )
    CHGT=(0.35*SQRT(0.3))*(((GRAV/OTEMP)**(1./3.))*(HGT**(1./3.)) *(HET**(1./3.)))
    CDELT = ( GAM * HGT * CHGT - HET ) / HGT
    CTHETA = ( HET / HGT ) - RAD + ADVGT
  ELSE
    DELTX = DELTA / 10
    do I = 1 , 10
      APTEMP = ( CTHETA * DELTX ) + APTEMP
      ATEMP = APTEMP - Tdif_50
      DELT = ( CDELT * DELTX ) + DELT
      IF ( DELT < 0.01 ) DELT = 0.01
      HGT = ( CHGT * DELTX ) + HGT
      HET = HEAT / ( DENS * CP )
      DHET = -0.5*HET/((1.+(2.6*(HET**(2./3.))/((GRAV*HGT/OTEMP)**(1./3.)*DELT))))

      CHGT = - DHET / DELT
      CTHETA = ( ( HET - DHET ) / HGT ) - RAD + ADVGT
      CDELT = ((GAM*HGT*CHGT)-(HET)-(DELT*CHGT))/HGT
    end do
  END IF

!** 12/3/91 Sounding Profile for course

  td(1) = aptemp
  zmix = ZA
  do l = 2, ntrp
    zmix = zmix + DELTAZ
    if (zmix < hgt) then
      td(l) = aptemp
    endif
  end do

! ** tdel is at the height just above the mixing layer
! ** ttop is at the height of the mixing layer

  tdel = aptemp + cdelt
  ttop = aptemp

! **  YCOUNT advanced to set the mode definitely for the daytime.

  YCOUNT = YCOUNT + 1.

  RETURN
END


subroutine  PSGCAL
  use simsphere_mod, only: thmax, thv, psis, cosbyb, psig
  implicit none

  real :: perwmax, perw2g, rlogpsig, rnpsig

!	REAL RLOGPSIL

!      INCLUDE 'modvars.h'

! **  Calculates the conductivity of the soil
! **  Cosby curves and coefficients (1984)

!  Field Capacity(75% of THMAX) used instead of THMAX.  Lower value
!  felt to fit local measurements better than the fit with tabulated
!  values.

! **  convert ground water contents to percents

  PERWMAX = THMAX * 100 * 0.75
  PERW2G = THV * 100
  RLOGPSIG = ALOG10 ( PSIS ) + COSBYB * ALOG10 ( PERWMAX )              &
             - COSBYB * ALOG10 ( PERW2G )

! * * psig is positive in this program

  RNPSIG = 10 ** ( RLOGPSIG )

! * * convert cm to bars

  PSIG = -RNPSIG / 1020

  return
end


module spherepack_interfaces

    use spherepack_precision, only: &
        wp, & ! working precision
        ip ! integer precision

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: get_wavetable_size, init_wavetable
    public :: scalar_analysis, scalar_synthesis
    public :: vector_analysis, vector_synthesis

    abstract interface
        pure function get_wavetable_size(nlat, nlon) &
            result(return_value)
            import :: ip

            ! Dummy arguments
            integer(ip), intent(in) :: nlat
            integer(ip), intent(in) :: nlon
            integer(ip)             :: return_value
        end function get_wavetable_size

        subroutine init_wavetable(nlat, nlon, wavetable, error_flag)
            import :: ip, wp

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            real(wp),    intent(out) :: wavetable(:)
            integer(ip), intent(out) :: error_flag
        end subroutine init_wavetable

        subroutine scalar_analysis(nlat, nlon, isym, nt, g, idg, jdg, a, b, &
            mdab, ndab, wavetable, error_flag)
            import :: ip, wp

            ! Dummy arguments
            integer(ip), intent(in)   :: nlat
            integer(ip), intent(in)   :: nlon
            integer(ip), intent(in)   :: isym
            integer(ip), intent(in)   :: nt
            real(wp),    intent(in)   :: g(idg, jdg, nt)
            integer(ip), intent(in)   :: idg
            integer(ip), intent(in)   :: jdg
            real(wp),    intent(out)  :: a(mdab, ndab, nt)
            real(wp),    intent(out)  :: b(mdab, ndab, nt)
            integer(ip), intent(in)   :: mdab
            integer(ip), intent(in)   :: ndab
            real(wp),    intent(in)   :: wavetable(:)
            integer(ip), intent(out)  :: error_flag
        end subroutine scalar_analysis

        subroutine scalar_synthesis(nlat, nlon, isym, nt, g, idg, jdg, a, b, &
            mdab, ndab, wavetable, error_flag)
            import :: ip, wp

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: isym
            integer(ip), intent(in)  :: nt
            real(wp),    intent(out) :: g(idg, jdg, nt)
            integer(ip), intent(in)  :: idg
            integer(ip), intent(in)  :: jdg
            real(wp),    intent(in)  :: a(mdab, ndab, nt)
            real(wp),    intent(in)  :: b(mdab, ndab, nt)
            integer(ip), intent(in)  :: mdab
            integer(ip), intent(in)  :: ndab
            real(wp),    intent(in)  :: wavetable(:)
            integer(ip), intent(out) :: error_flag
        end subroutine scalar_synthesis

        subroutine vector_analysis(nlat, nlon, ityp, nt, v, w, idvw, jdvw, &
            br, bi, cr, ci, mdab, ndab, wavetable, error_flag)
            import :: ip, wp

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: ityp
            integer(ip), intent(in)  :: nt
            real(wp),    intent(in)  :: v(idvw, jdvw, nt)
            real(wp),    intent(in)  :: w(idvw, jdvw, nt)
            integer(ip), intent(in)  :: idvw
            integer(ip), intent(in)  :: jdvw
            real(wp),    intent(out) :: br(mdab, ndab, nt)
            real(wp),    intent(out) :: bi(mdab, ndab, nt)
            real(wp),    intent(out) :: cr(mdab, ndab, nt)
            real(wp),    intent(out) :: ci(mdab, ndab, nt)
            integer(ip), intent(in)  :: mdab
            integer(ip), intent(in)  :: ndab
            real(wp),    intent(in)  :: wavetable(:)
            integer(ip), intent(out) :: error_flag
        end subroutine vector_analysis

        subroutine vector_synthesis(nlat, nlon, ityp, nt, v, w, idvw, jdvw, &
            br, bi, cr, ci, mdab, ndab, wavetable, error_flag)
            import :: ip, wp

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: ityp
            integer(ip), intent(in)  :: nt
            real(wp),    intent(out) :: v(idvw, jdvw, nt)
            real(wp),    intent(out) :: w(idvw, jdvw, nt)
            integer(ip), intent(in)  :: idvw
            integer(ip), intent(in)  :: jdvw
            real(wp),    intent(in)  :: br(mdab, ndab, nt)
            real(wp),    intent(in)  :: bi(mdab, ndab, nt)
            real(wp),    intent(in)  :: cr(mdab, ndab, nt)
            real(wp),    intent(in)  :: ci(mdab, ndab, nt)
            integer(ip), intent(in)  :: mdab
            integer(ip), intent(in)  :: ndab
            real(wp),    intent(in)  :: wavetable(:)
            integer(ip), intent(out) :: error_flag
        end subroutine vector_synthesis
    end interface

end module spherepack_interfaces


#:mute
#:include "common.fpp"

#:def gesvd(NAME,TYPE,KIND)
#:if TYPE == COMPLEX_TYPE
pure subroutine ${NAME}$(jobu,jobvt,m,n,a,lda,s,u,ldu,vt,ldvt,work,lwork,rwork,info)
#:else
pure subroutine ${NAME}$(jobu,jobvt,m,n,a,lda,s,u,ldu,vt,ldvt,work,lwork,info)
#:endif
    import :: ${KIND}$
@:parameter(integer, wp=${KIND}$)
@:args(${TYPE}$,  inout, a(lda,*))
@:args(${REAL_TYPE}$, out, s(*))
@:args(${TYPE}$,  out,   u(ldu,*), vt(ldvt,*))
@:args(integer,   out,   info)
@:args(character, in,    jobu, jobvt)
@:args(integer,   in,    m, n, lda, ldu, ldvt, lwork)
@:args(${TYPE}$,  inout, work(*))
#:if TYPE == COMPLEX_TYPE
@:args(${REAL_TYPE}$, in, rwork(*))
#:endif
end subroutine
#:enddef

#:def hegv(NAME,TYPE,KIND)
pure subroutine ${NAME}$(itype, jobz, uplo, n, a, lda, b, ldb, w, work, lwork, rwork, info)
    import :: ${KIND}$
@:parameter(integer, wp=${KIND}$)
@:args(${TYPE}$,  inout, a(lda,*))
@:args(${TYPE}$,  inout, b(ldb,*))
@:args(${REAL_TYPE}$, out, w(*))
@:args(integer,   out,   info)
@:args(character, in,    jobz, uplo)
@:args(integer,   in,    n, itype, lda, ldb, lwork)
@:args(${TYPE}$,  inout, work(*))
@:args(${REAL_TYPE}$, in, rwork(*))
end subroutine
#:enddef

#:def heevd(NAME,TYPE,KIND)
pure subroutine ${NAME}$(jobz, uplo, n, a, lda, w, work, lwork, rwork, lrwork, iwork, liwork, info)
    import :: ${KIND}$
@:parameter(integer, wp=${KIND}$)
@:args(${TYPE}$,      inout, a(lda,*))
@:args(${REAL_TYPE}$, out,   w(*))
@:args(integer,       out,   info)
@:args(character,     in,    jobz, uplo)
@:args(integer,       in,    n, lda, lwork, lrwork, liwork)
@:args(${TYPE}$,      inout, work(*))
@:args(${REAL_TYPE}$, inout, rwork(*))
@:args(integer,       inout, iwork(*))
end subroutine
#:enddef

#:def potrf_potri(NAME,TYPE,KIND)
pure subroutine ${NAME}$(uplo, n, a, lda, info)
    import :: ${KIND}$
@:parameter(integer, wp=${KIND}$)
@:args(${TYPE}$,  in, a(lda,*))
@:args(character, in,  uplo)
@:args(integer,   in,  n, lda)
@:args(integer,   out, info)
end subroutine
#:enddef

#:endmute
module f77_lapack
use iso_fortran_env
implicit none

$:f77_interface('?hegv',   COMPLEX_TYPES, hegv)
$:f77_interface('?heevd',  COMPLEX_TYPES, heevd)
$:f77_interface('?gesvd',  DEFAULT_TYPES, gesvd)
$:f77_interface('?potrf',  DEFAULT_TYPES, potrf_potri)
$:f77_interface('?potri',  DEFAULT_TYPES, potrf_potri)

end module


      SUBROUTINE DISREG(A,NA,B,NB,H,NH,Q,NQ,R,NR,F,NF,P,NP,IOP,IDENT,DU
     1MMY)
C
C   PURPOSE:
C      Solve the time-invariant discrete-time linear optimal output
C      regulator problem with noise-free measurements.
C
C   REFERENCES:
C      Astrom, Karl J.: Introduction to Stochastic Control Theory.
C        Academic Press, Inc., 1970.
C
C   Subroutines employed by DISREG: ADD, DSICO, DSISL, EQUATE, LNCNT,
C      MAXEL, MULT, PRNT, SUBT, TRANP
C   Subroutines employing DISREG: ASYREG
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(1),B(1),Q(1),R(1),F(1),P(1),DUMMY(1)
      DIMENSION NA(2),NB(2),NQ(2),NR(2),NF(2),NP(2)
      DIMENSION IOP(3)
      DIMENSION H(1),NH(2),NDUM(2)
      LOGICAL  IDENT
      COMMON/TOL/EPSAM,EPSBM,IACM
      COMMON/CONV/SUMCV,MAXSUM,RICTCV,SERCV
C
      N = NA(1)**2
      N1= N +1
      N2= N1+N
      N3= N2+N
C
      KSS = 0
      I=IOP(3)
C
      IF(IOP(1) .EQ. 0)  GO TO 85
      CALL LNCNT(5)
      WRITE(6,25)
   25 FORMAT(//' PROGRAM TO SOLVE THE TIME-INVARIANT FINITE-DURATION OPT
     1IMAL'/' DIGITAL REGULATOR PROBLEM WITH NOISE-FREE MEASUREMENTS'/)
      CALL PRNT(A,NA,' A  ',1)
      CALL PRNT(B,NB,' B  ',1)
      CALL PRNT(Q,NQ,' Q  ',1)
      IF( .NOT. IDENT )  GO TO 45
      CALL LNCNT(3)
      WRITE(6,35)
   35 FORMAT(/' H IS AN IDENTITY MATRIX'/)
      GO TO 65
   45 CONTINUE
      CALL PRNT(H,NH,' H  ',1)
      CALL MULT(Q,NQ,H,NH,DUMMY,NH)
      CALL TRANP(H,NH,DUMMY(N1),NF)
      CALL MULT(DUMMY(N1),NF,DUMMY,NH,Q,NQ)
      CALL LNCNT(3)
      WRITE(6,55)
   55 FORMAT(/' MATRIX ( H TRANSPOSE )QH'/)
      CALL PRNT(Q,NQ,'HTQH',1)
   65 CONTINUE
      CALL PRNT(R,NR,' R  ',1)
      CALL LNCNT(4)
      WRITE(6,75)
   75 FORMAT(//' WEIGHTING ON TERMINAL VALUE OF STATE VECTOR'/)
      CALL PRNT(P,NP,' P  ',1)
C
   85 CONTINUE
      IF((IOP(1) .NE. 0)  .OR. IDENT)  GO TO 100
      CALL MULT(Q,NQ,H,NH,DUMMY,NH)
      CALL TRANP(H,NH,DUMMY(N1),NF)
      CALL MULT(DUMMY(N1),NF,DUMMY,NH,Q,NQ)
C
  100 CONTINUE
      I=I-1
      CALL EQUATE(P,NP,DUMMY,NP)
      CALL MULT(P,NP,A,NA,DUMMY(N1),NA)
      CALL TRANP(B,NB,DUMMY(N2),NF)
      CALL MULT(DUMMY(N2),NF,DUMMY(N1),NA,F,NF)
      CALL MULT(P,NP,B,NB,DUMMY(N1),NB)
      CALL MULT(DUMMY(N2),NF,DUMMY(N1),NB,DUMMY(N3),NR)
      CALL ADD(R,NR,DUMMY(N3),NR,DUMMY(N1),NR)
      IOPT = 3
      IAC=IACM
      MF = NR(1)
C
C   * * *  CALL TO MATHLIB FUNCTIONS * * *
      CALL DSICO(DUMMY(N1),MF,MF,DUMMY(N2),RCOND,DUMMY(N3))
      IF ((1.0 + RCOND) .NE. 1.0) GO TO 300
      CALL LNCNT(5)
      WRITE(6,200) I,RCOND
  200 FORMAT(//' IN DISREG, THE MATRIX R + B(TRANS)*P(',I2,')*B IS SIN',
     1 'GULAR TO WORKING PRECISION, RCOND = ',D16.8)
      RETURN
C
  300 CONTINUE
      NT = 1
      DO 325 M1 = 1,NF(2)
         CALL DSISL(DUMMY(N1),MF,MF,DUMMY(N2),F(NT))
         NT = NT + MF
  325 CONTINUE
      CALL MULT(R,NR,F,NF,DUMMY(N1),NF)
      CALL TRANP(F,NF,DUMMY(N2),NB)
      CALL MULT(DUMMY(N2),NB,DUMMY(N1),NF,P,NP)
      CALL ADD(Q,NQ,P,NP,P,NP)
      CALL MULT(B,NB,F,NF,DUMMY(N1),NA)
      CALL SUBT(A,NA,DUMMY(N1),NA,DUMMY(N1),NA)
      CALL MULT(DUMMY,NA,DUMMY(N1),NA,DUMMY(N2),NA)
      CALL TRANP(DUMMY(N1),NA,DUMMY(N3),NA)
      CALL MULT(DUMMY(N3),NA,DUMMY(N2),NA,DUMMY(N1),NA)
      CALL ADD(P,NP,DUMMY(N1),NA,P,NP)
C
      IF( IOP(2) .EQ. 0 )  GO TO 400
      CALL LNCNT(5)
      WRITE(6,350) I
  350 FORMAT(///' STAGE ',I5,/)
      CALL PRNT(F,NF,' F  ',1)
      CALL PRNT(P,NP,' P  ',1)
C
  400 CONTINUE
      IF( I .EQ. 0 )  GO TO 600
      CALL MAXEL(DUMMY,NP,ANORM1)
      CALL SUBT(DUMMY,NP,P,NP,DUMMY(N2),NP)
      CALL MAXEL(DUMMY(N2),NP,ANORM2)
      IF( ANORM1 .NE. 0.0 )  GO TO 500
      GO TO 100
C
  500 CONTINUE
      IF(ANORM1 .GT. 1.0 ) GO TO 550
      IF( ANORM2/ANORM1 .LT. RICTCV ) KSS = 1
      GO TO 575
  550 CONTINUE
      IF( ANORM2 .LT. RICTCV ) KSS=1
  575 CONTINUE
      IF( KSS .EQ. 1) GO TO 600
      GO TO 100
C
  600 CONTINUE
      K = IOP(1) + IOP(2)
      IF( K .EQ. 0 ) RETURN
      IF( KSS .EQ. 0) GO TO 700
      CALL LNCNT(4)
      WRITE(6,650)
  650 FORMAT(//' STEADY-STATE SOLUTION HAS BEEN REACHED IN  DISREG'/)
C
  700 CONTINUE
      IF( IOP(2) .NE. 0 )  RETURN
      IF( IOP(1) .EQ. 0 )  RETURN
      CALL LNCNT(3)
      I = IOP(3)-I
      WRITE(6,800) I
  800 FORMAT(/' F AND P AFTER ',I5 ,' STEPS'/)
      CALL PRNT(F,NF,' F  ',1)
      CALL PRNT(P,NP,' P  ',1)
C
      RETURN
      END


C
C $Id: mdgnin.f,v 1.9 2008-09-18 00:42:17 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 MDGNIN (DANG,DNCE)
C
        DOUBLE PRECISION DANG,DNCE
C
C This routine, given a particular angular "step" DANG, in degrees,
C returns the largest "nice" value which is smaller than or equal to
C that step (probably to be used as the interval between labels on
C a grid).
C
C Declare arrays in which to put "nice" values in degrees, minutes, and
C seconds, respectively.
C
        DOUBLE PRECISION TDEG(8),TMIN(7),TSEC(7)
C
C Declare other local variables.
C
        INTEGER       I
C
C Define the "nice" values.
C
        DATA TDEG / 90.D0,45.D0,30.D0,15.D0,10.D0, 5.D0, 2.D0,1.D0 /
        DATA TMIN / 30.D0,20.D0,15.D0,10.D0, 5.D0, 2.D0, 1.D0 /
        DATA TSEC / 30.D0,20.D0,15.D0,10.D0, 5.D0, 2.D0, 1.D0 /
C
C Look for a nice interval which is an integral number of degrees.
C
        DO 101 I=1,8
          IF (DANG.GE.TDEG(I)) THEN
            DNCE=TDEG(I)
            RETURN
          END IF
  101   CONTINUE
C
C Look for a nice interval which is an integral number of minutes.
C
        DO 102 I=1,7
          IF (60.D0*DANG.GE.TMIN(I)) THEN
            DNCE=TMIN(I)/60.D0
            RETURN
          END IF
  102   CONTINUE
C
C Look for a nice interval which is an integral number of seconds.
C
        DO 103 I=1,7
          IF (3600.D0*DANG.GE.TSEC(I)) THEN
            DNCE=TSEC(I)/3600.D0
            RETURN
          END IF
  103   CONTINUE
C
C Failed to find a nice interval; return a zero.
C
        DNCE=0.D0
C
C Done.
C
        RETURN
C
      END


subroutine fst(n, s, w)
  use fstpack, only: rfst1f
  implicit none
  integer, intent(in)  :: n
  real,    intent(in)  :: s(n)
  complex, intent(out) :: w(n/2+1, n)
  integer :: err

  call rfst1f(s, w, err)
  if(err /= 0) error stop
end subroutine

subroutine ifst(n, w, s)
  use fstpack, only: rfst1b
  implicit none
  integer, intent(in)  :: n
  complex, intent(in)  :: w(n/2+1, n)
  real,    intent(out) :: s(n)
  integer :: err

  call rfst1b(w, s, err)
  if(err /= 0) error stop
end subroutine

! subroutine fst2(m, n, s, w)
!   use fstpack, only: fst2_ => fst2
!   implicit none
!   integer, intent(in)  :: m, n
!   real,    intent(in)  :: s(m, n)
!   complex, intent(out) :: w(m/2+1, n/2+1, m, n)

!   call fst2_(s, w)
! end subroutine

! subroutine ifst2(m, n, w, s)
!   use fstpack, only: ifst2_ => ifst2
!   implicit none
!   integer, intent(in)  :: m, n
!   complex, intent(in)  :: w(m/2+1, n/2+1, m, n)
!   real,    intent(out) :: s(m, n)

!   call ifst2_(s, w)
! end subroutine


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c ... file trssph.f
c
c     contains documentation and code for subroutine trssph
c
c ... required files
c
c     sphcom.f, hrfft.f, gaqd.f, shaec.f, shsec.f, shagc.f, shsgc.f
c
c
c     subroutine trssph(intl,igrida,nlona,nlata,da,igridb,nlonb,nlatb,
c    +db,wsave,lsave,lsvmin,work,lwork,lwkmin,dwork,ldwork,ier)
c
c *** purpose
c
C*PL*ERROR* Comment line too long
c     subroutine trssph transfers data given in array da on a grid on the
c     full sphere to data in array db on a grid on the full sphere.  the
c     grids on which da is given and db is generated can be specified
C*PL*ERROR* Comment line too long
c     independently of each other (see description below and the arguments
c     igrida,igridb).  for transferring vector data on the sphere, use
c     subroutine trvsph.

C*PL*ERROR* Comment line too long
c     notice that scalar and vector quantities are fundamentally different
C*PL*ERROR* Comment line too long
c     on the sphere.  for example, vectors are discontinuous and multiple
C*PL*ERROR* Comment line too long
c     valued at the poles.  scalars are continuous and single valued at the
C*PL*ERROR* Comment line too long
c     poles. erroneous results would be produced if one attempted to transfer
c     vector fields between grids with subroutine trssph applied to each
c     component of the vector.
c
c
c *** underlying grid assumptions and a description
c
C*PL*ERROR* Comment line too long
c     discussions with the ncar scd data support group and others indicate
C*PL*ERROR* Comment line too long
c     there is no standard grid for storing observational or model generated
c     data on the sphere.  subroutine trssph was designed to handle most
C*PL*ERROR* Comment line too long
c     cases likely to be encountered when moving data from one grid format
c     to another.
c
c     the grid on which da is given must be equally spaced in longitude
c     and either equally spaced or gaussian in latitude (or colatitude).
C*PL*ERROR* Comment line too long
c     longitude, which can be either the first or second dimension of da,
C*PL*ERROR* Comment line too long
c     subdivides [0,2pi) excluding the periodic point 2pi.  (co)latitude,
c     which can be the second or first dimension of da, has south
c     to north or north to south orientation with increasing subscript
c     value in da (see the argument igrida).
c
C*PL*ERROR* Comment line too long
c     the grid on which db is generated must be equally spaced in longitude
c     and either equally spaced or gaussian in latitude (or colatitude).
C*PL*ERROR* Comment line too long
c     longitude, which can be either the first or second dimension of db,
C*PL*ERROR* Comment line too long
c     subdivides [0,2pi) excluding the periodic point 2pi.  (co)latitude,
c     which can be the second or first dimension of db, has south
c     to north or north to south orientation with increasing subscript
c     value in db (see the argument igridb).
c
c     let nlon be either nlona or nlonb (the number of grid points in
c     longitude.  the longitude grid subdivides [0,2pi) into nlon spaced
c     points
c
c          (j-1)*2.*pi/nlon  (j=1,...,nlon).
c
C*PL*ERROR* Comment line too long
c     it is not necessary to communicate to subroutine trssph whether the
C*PL*ERROR* Comment line too long
c     underlying grids are in latitude or colatitude.  it is only necessary
C*PL*ERROR* Comment line too long
c     to communicate whether they run south to north or north to south with
C*PL*ERROR* Comment line too long
c     increasing subscripts.  a brief discussion of latitude and colatitude
c     follows.  equally spaced latitude grids are assumed to subdivide
c     [-pi/2,pi/2] with the south pole at -pi/2 and north pole at pi/2.
C*PL*ERROR* Comment line too long
c     equally spaced colatitude grids subdivide [0,pi] with the north pole
C*PL*ERROR* Comment line too long
c     at 0 and south pole at pi.  equally spaced partitions on the sphere
C*PL*ERROR* Comment line too long
c     include both poles.  gaussian latitude grids subdivide (-pi/2,pi/2)
C*PL*ERROR* Comment line too long
c     and gaussian colatitude grids subdivide (0,pi).  gaussian grids do not
C*PL*ERROR* Comment line too long
c     include the poles.  the gaussian grid points are uniquely determined by
c     the size of the partition.  they can be computed in colatitude in
C*PL*ERROR* Comment line too long
c     (0,pi) (north to south) in double precision by the spherepack subroutine
c     gaqd.  let nlat be nlata or nlatb if either the da or db grid is
c     gaussian.  let
c
c        north pole                             south pole
c        ----------                             ----------
c           0.0    <  cth(1) < ... < cth(nlat)  <   pi
c
c
c     be nlat gaussian colatitude points in the interval (0,pi) and let
c
c        south pole                        north pole
c        ----------                        ----------
c           -pi/2  < th(1) < ... < th(nlat) < pi/2
c
C*PL*ERROR* Comment line too long
c     be nlat gaussian latitude points in the open interval (-pi/2,pi/2).
c     these are related by
c
c          th(i) = -pi/2 + cth(i)  (i=1,...,nlat)
c
c     if the da or db grid is equally spaced in (co)latitude then
c
c          ctht(i) = (i-1)*pi/(nlat-1)
c                                               (i=1,...,nlat)
c          tht(i) = -pi/2 + (i-1)*pi/(nlat-1)
c
C*PL*ERROR* Comment line too long
c     define the equally spaced (north to south) colatitude and (south to
c     north) latitude grids.
c
c
c *** method (simplified description)
c
C*PL*ERROR* Comment line too long
c     for simplicity, assume da is a nlat by nlon data tabulation and da(i,j)
c     is the value at latitude theta(i) and longitude phi(j).  then
C*PL*ERROR* Comment line too long
c     coefficients a(m,n) and b(m,n) can be determined so that da(i,j) is
c     approximated by the sum
c
c         l-1  n
C*PL*ERROR* Comment line too long
c     (a) sum sum pbar(m,n,theta(i))*(a(m,n)*cos(m*phi(j)+b(m,n)*sin(m*phi(j))
c         n=0 m=0
c
C*PL*ERROR* Comment line too long
c     here pbar(n,m,theta) are the normalized associated legendre functions
C*PL*ERROR* Comment line too long
c     and l = min0(nlat,(nlon+2)/2).  the determination of a(m,n) and b(m,n)
C*PL*ERROR* Comment line too long
c     is called spherical harmonic analysis. a sum of this form can then be
c     used to regenerate the data in db on the new grid with the known
C*PL*ERROR* Comment line too long
c     a(m,n) and b(m,n).  this is referred to spherical harmonic synthesis.
C*PL*ERROR* Comment line too long
c     analysis and synthesis subroutines from the software package spherepack,
c     are used for these purposes.
c
C*PL*ERROR* Comment line too long
c     if da or db is not in mathematical spherical coordinates then array
C*PL*ERROR* Comment line too long
c     transposition and/or subscript reordering is used prior to harmonic
c     analysis and after harmonic synthesis.
c
c *** advantages
c
C*PL*ERROR* Comment line too long
c     the use of surface spherical harmonics to transfer spherical grid data
C*PL*ERROR* Comment line too long
c     has advantages over pointwise grid interpolation schemes on the sphere.
C*PL*ERROR* Comment line too long
c     it is highly accurate.  if p(x,y,z) is any polynomial of degree n or
C*PL*ERROR* Comment line too long
c     less in x,y,z cartesian coordinates which is restricted to the surface
C*PL*ERROR* Comment line too long
c     of the sphere, then p is exactly represented by sums of the form (a)
C*PL*ERROR* Comment line too long
c     whenever n = mino(nlat,nlon/2) (i.e., transfers with spherical harmonics
C*PL*ERROR* Comment line too long
c     have n(th) order accuracy.  by way of contrast, bilinear interpolation
C*PL*ERROR* Comment line too long
c     schemes are exact for polynomials of degree one.  bicubic interpolation
c     is exact only for polynomials of degree three or less.  the method
C*PL*ERROR* Comment line too long
c     also produces a weighted least squares fit to the data in which waves
C*PL*ERROR* Comment line too long
c     are resolved uniformly on the full sphere.  high frequencies, induced
c     by closeness of grid points near the poles (due to computational
c     or observational errors) are smoothed.  finally, the method is
C*PL*ERROR* Comment line too long
c     consistent with methods used to generate data in numerical spectral
C*PL*ERROR* Comment line too long
c     models based on spherical harmonics.  for more discussion of these and
C*PL*ERROR* Comment line too long
c     related issues,  see the article: "on the spectral approximation of
C*PL*ERROR* Comment line too long
c     discrete scalar and vector functions on the sphere," siam j. numer.
c     anal., vol 16. dec 1979, pp. 934-949, by paul swarztrauber.
c
c
c *** comment
c
C*PL*ERROR* Comment line too long
c     on a nlon by nlat or nlat by nlon grid (gaussian or equally spaced)
c     spherical harmonic analysis generates and synthesis utilizes
c     min0(nlat,(nlon+2)/2)) by nlat coefficients.  consequently, for
c     da and db,  if either
c
c             min0(nlatb,(nlonb+2)/2) < min0(nlata,(nlona+2)/2)
c
c     or if
c
c             nlatb < nlata
c
C*PL*ERROR* Comment line too long
c     then all the coefficients generated by an analysis of da cannot be used
C*PL*ERROR* Comment line too long
c     in the synthesis which generates db.  in this case "information" can be
C*PL*ERROR* Comment line too long
c     lost in generating db.  more precisely, information will be lost if the
C*PL*ERROR* Comment line too long
c     analysis of da yields nonzero coefficients which are outside the bounds
C*PL*ERROR* Comment line too long
c     determined by the db grid.  nevertheless, transference of values with
C*PL*ERROR* Comment line too long
c     spherical harmonics will yield results consistent with grid resolution
c     and is highly accurate.
c
c
c *** input arguments
c
c ... intl
c
C*PL*ERROR* Comment line too long
c     an initialization argument which should be zero on an initial call to
c     trssph.  intl should be one if trssph is being recalled and
c
c          igrida,nlona,nlata,igridb,nlonb,nlatb
c
C*PL*ERROR* Comment line too long
c     have not changed from the previous call.  if any of these arguments
C*PL*ERROR* Comment line too long
c     have changed, intl=0 must be used to avoid undetectable errors.  calls
C*PL*ERROR* Comment line too long
c     with intl=1 bypass redundant computation and save time.  it can be used
C*PL*ERROR* Comment line too long
c     when transferring multiple data sets with the same underlying grids.
c
c
c ... igrida
c
C*PL*ERROR* Comment line too long
c     an integer vector dimensioned two which identifies the underlying grid
c     on the full sphere for the given data array da as follows:
c
c     igrida(1)
c
c     = -1
c     if the latitude (or colatitude) grid for da is an equally spaced
c     partition of [-pi/2,pi/2] ( or [0,pi] ) including the poles which
c     runs north to south
c
c     = +1
c     if the latitude (or colatitude) grid for da is an equally spaced
c     partition of [-pi/2,pi/2] ( or [0,pi] ) including the poles which
c     runs south to north
c
c     = -2
C*PL*ERROR* Comment line too long
c     if the latitude (or colatitude) grid for da is a gaussian partition
c     of (-pi/2,pi/2) ( or (0,pi) ) excluding the poles which runs north
c     to south
c
c     = +2
C*PL*ERROR* Comment line too long
c     if the latitude (or colatitude) grid for da is a gaussian partition
c     of (-pi/2,pi/2) ( or (0,pi) ) excluding the poles which runs south
c     north
c
c     igrida(2)
c
c     = 0 if the underlying grid for da is a nlona by nlata
c
c     = 1 if the underlying grid for da is a nlata by nlona
c
c
c ... nlona
c
C*PL*ERROR* Comment line too long
c     the number of longitude points on the uniform grid which partitions
C*PL*ERROR* Comment line too long
c     [0,2pi) for the given data array da.  nlona is also the first or second
c     dimension of da (see igrida(2)) in the program which calls trssph.
C*PL*ERROR* Comment line too long
c     nlona determines the grid increment in longitude as 2*pi/nlona. for
C*PL*ERROR* Comment line too long
c     example nlona = 72 for a five degree grid.  nlona must be greater than
c     or equal to 4.  the efficiency of the computation is improved when
c     nlona is a product of small prime numbers
c
c ... nlata
c
c     the number of points in the latitude (or colatitude) grid
c     for the given data array da.  nlata is also the first or second
c     dimension of da (see igrida(2)) in the program which calls trssph.
C*PL*ERROR* Comment line too long
c     if nlata is odd then the equator will be located at the (nlata+1)/2
c     gaussian grid point.  if nlata is even then the equator will be
c     located half way between the nlata/2 and nlata/2+1 grid points.
c
c *** note:
c     igrida(1)=-1 or igrida(1)=-2 and igrida(2)=1 corresponds to
c     the "usual" mathematical spherical coordinate system required
c     by most of the drivers in spherepack2.  igrida(1)=1 or igrida(1)=2
c     and igrida(2)=0 corresponds to the "usual" geophysical spherical
c     coordinate system.
c
c ... da
c
c     a two dimensional array that contains the data to be transferred.
C*PL*ERROR* Comment line too long
c     da must be dimensioned nlona by nlata in the program calling trssph if
C*PL*ERROR* Comment line too long
c     igrida(2) = 0.  da must be dimensioned nlata by nlona in the program
C*PL*ERROR* Comment line too long
c     calling trssph if igrida(2) = 1.  if da is not properly dimensioned
C*PL*ERROR* Comment line too long
c     and if the latitude (colatitude) values do not run south to north or
C*PL*ERROR* Comment line too long
c     north to south as flagged by igrida(1) (this cannot be checked!) then
c     incorrect results will be produced.
c
c ... igridb
c
C*PL*ERROR* Comment line too long
c     an integer vector dimensioned two which identifies the underlying grid
c     on the full sphere for the transformed data array db as follows:
c
c     igridb(1)
c
c     = -1
c     if the latitude (or colatitude) grid for db is an equally spaced
c     partition of [-pi/2,pi/2] ( or [0,pi] ) including the poles which
c     north to south
c
c     = +1
c     if the latitude (or colatitude) grid for db is an equally spaced
c     partition of [-pi/2,pi/2] ( or [0,pi] ) including the poles which
c     south to north
c
c     = -2
C*PL*ERROR* Comment line too long
c     if the latitude (or colatitude) grid for db is a gaussian partition
C*PL*ERROR* Comment line too long
c     of (-pi/2,pi/2) ( or (0,pi) ) excluding the poles which runs north to
c     south
c
c     = +2
C*PL*ERROR* Comment line too long
c     if the latitude (or colatitude) grid for db is a gaussian partition
C*PL*ERROR* Comment line too long
c     of (-pi/2,pi/2) ( or (0,pi) ) excluding the poles which runs south to
c     north
c
c
c     igridb(2)
c
c     = 0 if the underlying grid for db is a nlonb by nlatb
c
c     = 1 if the underlying grid for db is a nlatb by nlonb
c
c
c ... nlonb
c
C*PL*ERROR* Comment line too long
c     the number of longitude points on the uniform grid which partitions
C*PL*ERROR* Comment line too long
c     [0,2pi) for the transformed data array db.  nlonb is also the first or
c     second dimension of db (see igridb(2)) in the program which calls
C*PL*ERROR* Comment line too long
c     trssph.  nlonb determines the grid increment in longitude as 2*pi/nlonb.
C*PL*ERROR* Comment line too long
c     for example nlonb = 72 for a five degree grid.  nlonb must be greater
C*PL*ERROR* Comment line too long
c     than or equal to 4.  the efficiency of the computation is improved when
c     nlonb is a product of small prime numbers
c
c ... nlatb
c
c     the number of points in the latitude (or colatitude) grid
C*PL*ERROR* Comment line too long
c     for the transformed data array db.  nlatb is also the first or second
c     dimension of db (see igridb(2)) in the program which calls trssph.
C*PL*ERROR* Comment line too long
c     if nlatb is odd then the equator will be located at the (nlatb+1)/2
c     gaussian grid point.  if nlatb is even then the equator will be
c     located half way between the nlatb/2 and nlatb/2+1 grid points.
c
c ... wsave
c
c     a saved work space array that can be utilized repeatedly by trssph
c     as long as the arguments nlata,nlona,nlatb,nlonb remain unchanged.
C*PL*ERROR* Comment line too long
c     wsave is set by a intl=0 call to trssph.  wsave must not be altered
c     when trssph is being recalled with intl=1.
c
c ... lsave
c
c     the dimension of the work space wsave as it appears in the program
c     that calls trssph.  the minimum required value of lsave for the
C*PL*ERROR* Comment line too long
c     current set of input arguments is set in the output argument lsvmin.
C*PL*ERROR* Comment line too long
c     it can be determined by calling trssph with lsave=0 and printing lsvmin.
c     let
c
c          lwa =  2*nlata*la2+3*((la1-2)*(nlata+nlata-la1-1))/2+nlona+15
c
c     if the grid for da is equally spaced in (co)latitude.  let
c
c          lwa = nlata*(2*la2+3*la1-2)+3*la1*(1-la1)/2+nlona+15
c
c     if the grid for da is gaussian in (co)latitude.
c     let
c
c          lwb = nlatb*(2*lb2+3*lb1-2)+3*lb1*(1-lb1)/2+nlonb+15
c
c     if the grid for db is gaussian in (co)latitude.  let
c
c          lwb = 2*nlatb*lb2+3*((lb1-2)*(nlatb+nlatb-lb1-1))/2+nlonb+15
c
c     if the grid for db is equally spaced in (co)latitude.  then
c     the quantity
c
c          lwa + lwb
c
c     is the minimum required length of wsave.  this value is returned
C*PL*ERROR* Comment line too long
c     in the output argument lsvmin even if lsave is to small (ierror=10)
c
c ... work
c
c     a real work array that does not have to be preserved
c
c ... lwork
c
c     the dimension of the array work as it appears in the program
C*PL*ERROR* Comment line too long
c     calling trssph. the minimum required value of lwork for the current
c     set of input arguments is set in the output argument lwkmin.
c     it can be determined by calling trssph with lwork=0 and printing
c     lwkmin.  an estimate for lwork follows.  let nlat,nlon,l1,l2 be
c     defined by
c
c       nlat = max0(nlata,nlatb), nlon = nax0(nlona,nlonb),
c       l1 = min0(nlat,(nlon+2)/2), l2 = (nlat+1)/2
c
c     then the quantity
c
c          nlat*(4*l1+nlon+2*nlat+4)+3*((l1-2)*2*(2*nlat-l1-1))/2
c
c     will suffice as a length for the unsaved work space.
c
C*PL*ERROR* Comment line too long
c  *  both of the formulas above for lsave and lwork may overestimate the
C*PL*ERROR* Comment line too long
c     required minimum values.  they can be predetermined by calling trssph
c     with lsave=lwork=0 and printout of lsvmin and lwkmin.
c
c ... dwork
c
c     a double precision work array that does not have to be preserved.
c
c ... ldwork
c
c     The length of dwork in the routine calling trssph.
c     Let
c
c       nlat = max0(nlata,nlatb)
c
c     ldwork must be at least nlat*(nlat+4)
c
c *** output arguments
c
c
c ... db
c
c     a two dimensional array that contains the transformed data.  db
C*PL*ERROR* Comment line too long
c     must be dimensioned nlonb by nlatb in the program calling trssph if
c     igridb(2) = 0 or 1.  db must be dimensioned nlatb by nlonb in the
c     program calling trssph if igridb(2) = 1.  if db is not properly
C*PL*ERROR* Comment line too long
c     dimensioned and if the latitude (colatitude) values do not run south
C*PL*ERROR* Comment line too long
c     north or north to south as flagged by igrdb(1) (this cannot be checked!)
c     then incorrect results will be produced.
c
c ... lsvmin
c
c     the minimum length of the saved work space in wsave.
c     lsvmin is computed even if lsave < lsvmin (ier = 10).
c
c ... lwkmin
c
c     the minimum length of the unsaved work space in work.
c     lwkmin is computed even if lwork < lwkmin (ier = 11).
c
c *** error argument
c
c ... ier = 0  if no errors are detected
c
c         = 1  if intl is not 0 or 1
c
c         = 2  if igrida(1) is not -1 or +1 or -2 or +2
c
c         = 3  if igrida(2) is not 0 or 1
c
c         = 4  if nlona is less than 4
c
c         = 5  if nlata is less than 3
c
c         = 6  if igridb(1) is not -1 or +1 or -2 or +2
c
c         = 7  if igridb(2) is not 0 or 1
c
c         = 8  if nlonb is less than 4
c
c         = 9  if nlatb is less than 3

C*PL*ERROR* Comment line too long
c         =10  if there is insufficient saved work space (lsave < lsvmin)
c
C*PL*ERROR* Comment line too long
c         =11  if there is insufficient unsaved work space (lwork < lwkmin)
c
c         =12  indicates failure in an eigenvalue routine which computes
c              gaussian weights and points
c
C*PL*ERROR* Comment line too long
c         =13  if ldwork is too small (insufficient unsaved double precision
c              work space)
c
c *****************************************************
c *****************************************************
c
c     end of argument description ... code follows
c
c *****************************************************
c *****************************************************
c
      SUBROUTINE DTRSSPH(INTL,IGRIDA,NLONA,NLATA,DA,IGRIDB,NLONB,NLATB,
     +                  DB,WSAVE,LSAVE,LSVMIN,WORK,LWORK,LWKMIN,DWORK,
     +                  LDWORK,IER)
      IMPLICIT NONE
      INTEGER INTL,IGRIDA(2),NLONA,NLATA,IGRIDB(2),NLONB,NLATB
      INTEGER LSAVE,LSVMIN,LWORK,LWKMIN,LDWORK,IER
      DOUBLE PRECISION DA(*),DB(*),WSAVE(*),WORK(*)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION DWORK(*)
      INTEGER IG,IGRDA,IGRDB,LA1,LA2,LB1,LB2,LWA,LWB,IAA,IAB,IBA,IBB
      INTEGER LWK3,LWK4,LW,IW,JB,NT,ISYM,NLAT
c
C*PL*ERROR* Comment line too long
c     include a save statement to ensure local variables in trssph, set during
c     an intl=0 call, are preserved if trssph is recalled with intl=1
c
      SAVE
c
c     check input arguments
c
      IER = 1
      IF (INTL* (INTL-1).NE.0) RETURN
      IER = 2
      IG = IGRIDA(1)
      IF ((IG-1)* (IG+1)* (IG-2)* (IG+2).NE.0) RETURN
      IER = 3
      IG = IGRIDA(2)
      IF (IG* (IG-1).NE.0) RETURN
      IER = 4
      IF (NLONA.LT.4) RETURN
      IER = 5
      IF (NLATA.LT.3) RETURN
      IER = 6
      IG = IGRIDB(1)
      IF ((IG-1)* (IG+1)* (IG-2)* (IG+2).NE.0) RETURN
      IER = 7
      IG = IGRIDB(2)
      IF (IG* (IG-1).NE.0) RETURN
      IER = 8
      IF (NLONB.LT.4) RETURN
      IER = 9
      IF (NLATB.LT.3) RETURN
      IER = 0

      IGRDA = IABS(IGRIDA(1))
      IGRDB = IABS(IGRIDB(1))
      IF (INTL.EQ.0) THEN
          LA1 = MIN0(NLATA, (NLONA+2)/2)
          LA2 = (NLATA+1)/2
          LB1 = MIN0(NLATB, (NLONB+2)/2)
          LB2 = (NLATB+1)/2
c
c     set saved work space length for analysis
c
          IF (IGRDA.EQ.1) THEN
c
c     saved space for analysis on  equally spaced grid
c
              LWA = 2*NLATA*LA2 + 3* ((LA1-2)* (NLATA+NLATA-LA1-1))/2 +
     +              NLONA + 15
          ELSE
c
c     saved space for analysis on gaussian grid
c
              LWA = NLATA* (2*LA2+3*LA1-2) + 3*LA1* (1-LA1)/2 + NLONA +
     +              15
          END IF
c
c     set wsave pointer
c
          JB = 1 + LWA
c
c     set pointers for spherical harmonic coefs
c
          IAA = 1
          IBA = IAA + LA1*NLATA
          IAB = IBA + LA1*NLATA
          IF (IGRDB.EQ.2) THEN
c
c     set saved work space length for gaussian synthesis
c
              LWB = NLATB* (2*LB2+3*LB1-2) + 3*LB1* (1-LB1)/2 + NLONB +
     +              15
          ELSE
c
c     set saved work space length for equally spaced synthesis
c
              LWB = 2*NLATB*LB2 + 3* ((LB1-2)* (NLATB+NLATB-LB1-1))/2 +
     +              NLONB + 15
          END IF
c
c     set minimum saved work space length
c
          LSVMIN = LWA + LWB
c
c     set remaining harmonic pointer
c
          IBB = IAB + LB1*NLATB
c
c     set pointers for remaining work
c
          IW = IBB + LB1*NLATB
c
c     set remaining work space length in lw
c
          LW = LWORK - IW
          LWK3 = NLATA*NLONA*2
          LWK4 = NLATB*NLONB*2
c
c     set minimum unsaved work space required by trssph
c
          LWKMIN = IW + MAX0(LWK3,LWK4)
c
c     set error flags if saved or unsaved work spaces are insufficient
c
          IER = 10
          IF (LSAVE.LT.LSVMIN) RETURN
          IER = 11
          IF (LWORK.LT.LWKMIN) RETURN
          IER = 13
          NLAT = MAX0(NLATA,NLATB)
          IF (LDWORK.LT.NLAT* (NLAT+4)) RETURN
          IER = 0
          IF (IGRDA.EQ.1) THEN
c
c     initialize wsave for equally spaced analysis
c
              CALL DSHAECI(NLATA,NLONA,WSAVE,LWA,DWORK,LDWORK,IER)
          ELSE
c
c     initialize wsave for gaussian analysis
c
              CALL DSHAGCI(NLATA,NLONA,WSAVE,LWA,DWORK,LDWORK,IER)
              IF (IER.NE.0) THEN
c
c     flag failure in spherepack gaussian software
c
                  IER = 12
                  RETURN
              END IF
          END IF

          IF (IGRDB.EQ.2) THEN
c
c     initialize wsave for gaussian synthesis
c
              CALL DSHSGCI(NLATB,NLONB,WSAVE(JB),LWB,DWORK,LDWORK,IER)
              IF (IER.NE.0) THEN
c
c     flag failure in spherepack gaussian software
c
                  IER = 12
                  RETURN
              END IF
          ELSE
c
c     initialize wsave for equally spaced synthesis
c
              CALL DSHSECI(NLATB,NLONB,WSAVE(JB),LWB,DWORK,LDWORK,IER)
          END IF
c
c     end of initialization (intl=0) call
c
      END IF
c
c     transpose and/or reorder (co)latitude if necessary for da
c     (arrays must have latitude (colatitude) as the first dimension
c     and run north to south for spherepack software)
c
      IF (IGRIDA(2).EQ.0) CALL DTRSPLAT(NLONA,NLATA,DA,WORK)
      IF (IGRIDA(1).GT.0) CALL DCONVLAT(NLATA,NLONA,DA)

      NT = 1
      ISYM = 0
      IF (IGRDA.EQ.2) THEN
c
c     do spherical harmonic analysis of "adjusted" da on gaussian grid
c
          CALL DSHAGC(NLATA,NLONA,ISYM,NT,DA,NLATA,NLONA,WORK(IAA),
     +               WORK(IBA),LA1,NLATA,WSAVE,LWA,WORK(IW),LW,IER)
      ELSE
c
C*PL*ERROR* Comment line too long
c     do spherical harmonic analysis of "adjusted" da on equally spaced grid
c
          CALL DSHAEC(NLATA,NLONA,ISYM,NT,DA,NLATA,NLONA,WORK(IAA),
     +               WORK(IBA),LA1,NLATA,WSAVE,LWA,WORK(IW),LW,IER)
      END IF
c
c     transfer da grid coefficients to db grid coefficients
c     truncating to zero as necessary
c
      CALL DTRAB(LA1,NLATA,WORK(IAA),WORK(IBA),LB1,NLATB,WORK(IAB),
     +          WORK(IBB))

      IF (IGRDB.EQ.1) THEN
c
C*PL*ERROR* Comment line too long
c     do spherical harmonic synthesis on nlatb by nlonb equally spaced grid
c
          CALL DSHSEC(NLATB,NLONB,ISYM,NT,DB,NLATB,NLONB,WORK(IAB),
     +               WORK(IBB),LB1,NLATB,WSAVE(JB),LWB,WORK(IW),LW,IER)
      ELSE
c
c     do spherical harmonic synthesis on nlatb by nlonb gaussian grid
c
          CALL DSHSGC(NLATB,NLONB,ISYM,NT,DB,NLATB,NLONB,WORK(IAB),
     +               WORK(IBB),LB1,NLATB,WSAVE(JB),LWB,WORK(IW),LW,IER)
      END IF
c
C*PL*ERROR* Comment line too long
c     both da,db are currently latitude by longitude north to south arrays
c     restore da and set db to agree with flags in igrida and igridb
c
      IF (IGRIDA(1).GT.0) CALL DCONVLAT(NLATA,NLONA,DA)
      IF (IGRIDB(1).GT.0) CALL DCONVLAT(NLATB,NLONB,DB)
      IF (IGRIDA(2).EQ.0) CALL DTRSPLAT(NLATA,NLONA,DA,WORK)
      IF (IGRIDB(2).EQ.0) CALL DTRSPLAT(NLATB,NLONB,DB,WORK)
      RETURN
      END

      SUBROUTINE DTRAB(MA,NA,AA,BA,MB,NB,AB,BB)
      IMPLICIT NONE
      INTEGER MA,NA,MB,NB,I,J,M,N
      DOUBLE PRECISION AA(MA,NA),BA(MA,NA),AB(MB,NB),BB(MB,NB)
c
c     set coefficients for b grid from coefficients for a grid
c
      M = MIN0(MA,MB)
      N = MIN0(NA,NB)
      DO J = 1,N
          DO I = 1,M
              AB(I,J) = AA(I,J)
              BB(I,J) = BA(I,J)
          END DO
      END DO
c
c     set coefs outside triangle to zero
c
      DO I = M + 1,MB
          DO J = 1,NB
              AB(I,J) = 0.0D0
              BB(I,J) = 0.0D0
          END DO
      END DO
      DO J = N + 1,NB
          DO I = 1,MB
              AB(I,J) = 0.0D0
              BB(I,J) = 0.0D0
          END DO
      END DO
      RETURN
      END

      SUBROUTINE DTRSPLAT(N,M,DATA,WORK)
c
c     transpose the n by m array data to a m by n array data
c     work must be at least n*m words long
c
      IMPLICIT NONE
      INTEGER N,M,I,J,IJ,JI
      DOUBLE PRECISION DATA(*),WORK(*)

      DO J = 1,M
          DO I = 1,N
              IJ = (J-1)*N + I
              WORK(IJ) = DATA(IJ)
          END DO
      END DO
      DO I = 1,N
          DO J = 1,M
              JI = (I-1)*M + J
              IJ = (J-1)*N + I
              DATA(JI) = WORK(IJ)
          END DO
      END DO
      RETURN
      END

      SUBROUTINE DCONVLAT(NLAT,NLON,DATA)
c
c     reverse order of latitude (colatitude) grids
c
      IMPLICIT NONE
      INTEGER NLAT,NLON,NLAT2,I,IB,J
      DOUBLE PRECISION DATA(NLAT,NLON),TEMP

      NLAT2 = NLAT/2
      DO I = 1,NLAT2
          IB = NLAT - I + 1
          DO J = 1,NLON
              TEMP = DATA(I,J)
              DATA(I,J) = DATA(IB,J)
              DATA(IB,J) = TEMP
          END DO
      END DO
      RETURN
      END


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      PROGRAM EXMPL4
C     Example 4: Born and Eikonal Approximations to Quantum Scattering
C  COMPUTATIONAL PHYSICS (FORTRAN VERSION)
C  by Steven E. Koonin and Dawn C. Meredith
C  Copyright 1989, Addison-Wesley Publishing Company, Inc.
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      CALL INIT           !display header screen, setup parameters
5     CONTINUE            !main loop/ execute once for each set of param
        CALL PARAM        !get input from screen
        CALL ARCHON       !calculate cross sections
      GOTO 5
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE ARCHON
C calculates the Born, eikonal, and optical theorem total cross sections
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'IO.ALL'
      INCLUDE 'PARAM.E4'
C Local variables:
      REAL SINHLF                !sin theta_cut/2
      REAL THTCUT,COSCUT         !theta_cut/2, cos of the same
      REAL SIGBT,SIGBTF,SIGBTB   !Born cross sections
      REAL SIGET,SIGETF,SIGETB   !eikonal cross sections
      REAL SIGOPT,IMFE0          !optical cross sect, imag part of f(0)
      REAL COSTH                 !integration variable
      INTEGER ILEG,LANG          !index quad points, angle
      INTEGER NLINES             !number of lines printed to terminal
      INTEGER SCREEN             !send to terminal
      INTEGER PAPER              !make a hardcopy
      INTEGER FILE               !send to a file
      DATA SCREEN,PAPER,FILE/1,2,3/
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     output summary of parameters
      IF (TTERM) CALL PRMOUT(OUNIT,NLINES)
      IF (TFILE) CALL PRMOUT(TUNIT,NLINES)
      IF (GFILE) CALL PRMOUT(GUNIT,NLINES)
C
C     find angle at which q*rcut=2*pi to divide integral into
C       forward and backward scattering
      SINHLF=PI/(K*RCUT)
      IF (SINHLF.GT.SQHALF) SINHLF=SQHALF
      THTCUT=2*ATAN(SINHLF/SQRT(1-SINHLF*SINHLF))
      COSCUT=COS(THTCUT)
C
      SIGBT=0.0                         !zero sums
      SIGET=0.0
      IMFE0=0.0
C
C     integrate from theta=0 to theta=theta_cut
C      to find forward angle cross section
      DO 100 ILEG=1,NLEG
         COSTH=COSCUT+(XLEG(ILEG)+1)*(1-COSCUT)/2.0
         LANG=ILEG
         CALL DIFFCS(COSTH,ILEG,LANG,SIGET,SIGBT,IMFE0,NLINES)
100   CONTINUE
      SIGBTF=PI*(1-COSCUT)*SIGBT
      SIGETF=PI*(1-COSCUT)*SIGET
C
      SIGBT=0                           !zero sums
      SIGET=0
C
C     integrate from theta=theta_cut to theta=pi
C      to find backward angle cross section
      DO 200 ILEG=1,NLEG
         COSTH=-1+(XLEG(ILEG)+1)*(COSCUT+1)/2.0
         LANG=ILEG+NLEG
         CALL DIFFCS(COSTH,ILEG,LANG,SIGET,SIGBT,IMFE0,NLINES)
200   CONTINUE
      SIGBTB=PI*(COSCUT+1)*SIGBT
      SIGETB=PI*(COSCUT+1)*SIGET
C
C     add backward and forward scattering cross sections
      SIGBT=SIGBTF+SIGBTB
      SIGET=SIGETF+SIGETB
      SIGOPT=4*PI/K*IMFE0
C
C     output results
      IF (TTERM) CALL TOTOUT(OUNIT,THTCUT,SIGBT,SIGET,SIGOPT)
      IF (TFILE) CALL TOTOUT(TUNIT,THTCUT,SIGBT,SIGET,SIGOPT)
C
      IF (TTERM) CALL PAUSE('to continue...',1)
      IF (TTERM) CALL CLEAR
C
C     graphics output
      IF (GTERM) CALL GRFOUT(SCREEN)
      IF (GFILE) CALL GRFOUT(FILE)
      IF (GHRDCP) CALL GRFOUT(PAPER)
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE DIFFCS(COSTH,ILEG,LANG,SIGET,SIGBT,IMFE0,NLINES)
C calculate the differential cross section at a give angle (COSTH)
C and its contribution to the total cross section
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global Variables:
      INCLUDE 'PARAM.E4'
      INCLUDE 'IO.ALL'
C Passed Variables
      REAL SIGBT              !Born cross sections (output)
      REAL SIGET              !eikonal cross sections (output)
      REAL IMFE0              !imag part of f(0) (output)
      REAL COSTH              !integration variable (input)
      INTEGER ILEG,LANG       !index quad points, angle (input)
      INTEGER NLINES          !number of lines printed to terminal (I/O)
C Local Variables:
      REAL THETA,Q            !angle, momentum transfer
      REAL DEGREE(96)         !angle
      REAL SIGE(96)           !eikonal differential cross section
      REAL SIGB(96)           !born differential cross section
      COMMON/RESULT/DEGREE,SIGE,SIGB  !pass to graphics routine only
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      THETA=ATAN(SQRT(1-COSTH*COSTH)/COSTH)    !find the angle
      IF (THETA.LT.0.0) THETA=THETA+PI
      DEGREE(LANG)=THETA*180.0/PI
C
      Q=2*K*SIN(THETA/2.0)            !momentum transfer at this angle
C
      CALL BORN(Q,LANG,SIGB)          !calculate differential cross sect
      SIGBT=SIGBT+SIGB(LANG)*WLEG(ILEG) !and add to total cross sect
      CALL EIKONL(Q,LANG,SIGE,IMFE0)
      SIGET=SIGET+SIGE(LANG)*WLEG(ILEG)
C
      IF (TTERM)                        !text output
     &  CALL TXTOUT(OUNIT,DEGREE(LANG),Q,SIGB(LANG),SIGE(LANG),NLINES)
      IF (TFILE)
     &  CALL TXTOUT(TUNIT,DEGREE(LANG),Q,SIGB(LANG),SIGE(LANG),NLINES)
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE BORN(Q,LANG,SIGB)
C calculates the differential cross section in the Born approximation
C for one value of the momentum transfer (Q)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global Variables:
      INCLUDE 'PARAM.E4'
C Passed Variables
      REAL    Q                !momentum transfer (input)
      INTEGER LANG             !index of the angle (input)
      REAL SIGB(96)            !Born differential cross section (output)
C Local Variables:
      REAL    R                !radial variable
      REAL    FBORN            !scattering amplitude
      INTEGER J                !index of quadrature points
C Function:
      REAL V                   !potential
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      FBORN=0                                !zero sum
      DO 100 J=1,NLEG
         R=RMAX*(XLEG(J)+1)/2.0              !scale the variable
         FBORN=FBORN+SIN(Q*R)*V(R)*R*WLEG(J) !Gaussian quadrature
100   CONTINUE
      FBORN=-RMAX/(Q*HBARM)*FBORN
      SIGB(LANG)=FBORN*FBORN
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE EIKONL(Q,LANG,SIGE,IMFE0)
C calculates differential cross secton in the eikonal approximation
C for one value of the momentum transfer Q
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global Variables:
      INCLUDE 'PARAM.E4'
C Input/Output Variables
      REAL Q                       !momentum transfer (input)
      INTEGER LANG                 !index of the angle (input)
      REAL SIGE(96)                !eikonal diff cross section (output)
      REAL IMFE0                   !imag part of f(0) (output)
C Local Variables:
      REAL CHI(96)                 !profile function
      REAL B                       !impact parameter
      COMPLEX FE                   !scattering amplitude
      REAL ZMAX,ZZ                 !integration variable for CHI
      REAL R                       !radius
      REAL J0                      !Bessel function
      INTEGER M,J                  !index for quadrature
      REAL X                       !argument of Bessel function
      COMPLEX SQRTM1               !square root of minus 1
C Functions:
      REAL BESSJ0                  !zeroth Bessel function eval at X
      REAL V                       !potential
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SQRTM1=(0.,1.)               !constant
      FE=(0.,0.)                   !zero the scatt ampl
C
      DO 100 J=1,NLEG              !integrate over B
         B=RMAX*(XLEG(J)+1)/2.0
C
         IF (LANG .EQ. 1) THEN         !calculate profile function once
             CHI(J)=0.0
             ZMAX=SQRT(RMAX*RMAX-B*B)  !integration variable z
             DO 200 M=1,NLEG
                ZZ=ZMAX*(XLEG(M)+1)/2. !scale variable
                R=SQRT(ZZ*ZZ+B*B)      !calculate radius
                CHI(J)=CHI(J)+V(R)*WLEG(M)           !Gaussian quad
200          CONTINUE
             CHI(J)=-(ZMAX/(2*K*HBARM))*CHI(J)
             IMFE0=IMFE0+B*(SIN(CHI(J)))**2*WLEG(J)  !imag f(0)
         ENDIF
C
         X=Q*B
         J0=BESSJ0(X)
         FE=FE+B*J0*WLEG(J)*(EXP(2*SQRTM1*CHI(J))-1.)  !Gaussian quad
C
100   CONTINUE
C
      FE=-SQRTM1*K*RMAX*FE/2. !factor of RMAX/2 from change in variables
      SIGE(LANG)=ABS(FE)**2
      IF (LANG .EQ. 1) IMFE0=K*RMAX*IMFE0
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      REAL FUNCTION V(R)
C calculates the potential at fixed R
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'PARAM.E4'
C Input/Output Variables:
      REAL R                        !radius (input)
C Local Variables
      REAL RR                       !radius for Lenz-Jensen (.ge. R1S)
      REAL U                        !temp variable for Lenz-Jensen
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      IF (POT .EQ. SQUARE) THEN     !square well
         V=-VZERO
C
      ELSE IF (POT .EQ. GAUSS) THEN !Gaussian well
         V=-VZERO*EXP(-2*R*R)
C
      ELSE                       !Lenz-Jensen
         RR=R                    !cutoff radius at location of 1S shell
         IF (R .LT. R1S) RR=R1S
         U=4.5397*Z6*SQRT(RR)
         V=-((Z*E2)/RR)*EXP(-U)*(1+U+U*U*(.3344+U*(.0485+.002647*U)))
      ENDIF
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      REAL FUNCTION BESSJ0(X)
C calculates the zeroth order Bessel function at X
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global Variables:
      INCLUDE 'PARAM.E4'
C Input Variables:
      REAL X                      !argument of J_0
C Local Variables
      REAL Y,Y2,TEMP,TEMP2        !temporary variables to save values
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      Y=X/3.
      Y2=Y*Y
C
      IF ( ABS(X) .LE. 3.) THEN
          TEMP=-.0039444+.00021*Y2
          TEMP=.0444479+Y2*TEMP
          TEMP=-.3163866+Y2*TEMP
C
          TEMP=1.2656208+Y2*TEMP
          TEMP=-2.2499997+Y2*TEMP
          BESSJ0=1.+Y2*TEMP
      ELSE
          Y=1./Y
          TEMP=-7.2805E-04+1.4476E-04*Y
          TEMP=1.37237E-03+TEMP*Y
          TEMP=-9.512E-05+TEMP*Y
          TEMP=-.0055274+TEMP*Y
          TEMP=-7.7E-07+TEMP*Y
          TEMP=.79788456+TEMP*Y
          TEMP2=-2.9333E-04+1.3558E-04*Y
          TEMP2=-5.4125E-04+TEMP2*Y
          TEMP2=2.62573E-03+TEMP2*Y
          TEMP2=-3.954E-05+TEMP2*Y
          TEMP2=-4.166397E-02+TEMP2*Y
          TEMP2=X-.78539816+TEMP2*Y
          BESSJ0=TEMP*COS(TEMP2)/SQRT(X)
      ENDIF
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
       SUBROUTINE QUAD(NLBAD)
C subroutine to establish Gauss-Legendre abscissae and weights
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'PARAM.E4'
C Passed Variables
      LOGICAL NLBAD                   !allowed value of nleg?(output)
C Local Variables:
      INTEGER ILEG                    !index for abscissae and weights
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      NLBAD=.FALSE.
C
      IF (NLEG.EQ.2) THEN
         XLEG(1)=.577350269189626
         WLEG(1)=1.                   !nleg=2
      ELSE IF (NLEG.EQ.3) THEN
         XLEG(1)=.774596669241483
         WLEG(1)=.555555555555556     !NLEG=3
         XLEG(2)=0.
         WLEG(2)=.888888888888889
      ELSE IF (NLEG.EQ.4) THEN
         XLEG(1)=.861136311594053
         WLEG(1)=.347854845137454     !NLEG=4
         XLEG(2)=.339981043584856
         WLEG(2)=.652145154862546
      ELSE IF (NLEG.EQ.5) THEN
         XLEG(1)=.906179845938664
         WLEG(1)=.236926885056189     !NLEG=5
         XLEG(2)=.538469310105683
         WLEG(2)=.478628670499366
         XLEG(3)=0.
         WLEG(3)=.568888888888889
      ELSE IF (NLEG.EQ.6) THEN
         XLEG(1)=.932469514203152
         WLEG(1)=.17132449237917      !NLEG=6
         XLEG(2)=.661209386466266
         WLEG(2)=.360761573048139
         XLEG(3)=.238619186083197
         WLEG(3)=.467913934572691
      ELSE IF (NLEG.EQ.8) THEN
         XLEG(1)=.960289856497536
         WLEG(1)=.101228536290376    !NLEG=8
         XLEG(2)=.796666477413627
         WLEG(2)=.222381034453374
         XLEG(3)=.525532409916329
         WLEG(3)=.313706645877887
         XLEG(4)=.18343464249565
         WLEG(4)=.362683783378362
      ELSE IF (NLEG.EQ.10) THEN
         XLEG(1)=.973906528517172
         WLEG(1)=.066671344308688    !NLEG=10
         XLEG(2)=.865063366688985
         WLEG(2)=.149451349150581
         XLEG(3)=.679409568299024
         WLEG(3)=.219086362515982
         XLEG(4)=.433395394129247
         WLEG(4)=.269266719309996
         XLEG(5)=.148874338981631
         WLEG(5)=.295524224714753
      ELSE IF (NLEG.EQ.12) THEN
         XLEG(1)=.981560634246719
         WLEG(1)=.047175336386512    !NLEG=12
         XLEG(2)=.904117256370475
         WLEG(2)=.106939325995318
         XLEG(3)=.769902674194305
         WLEG(3)=.160078328543346
         XLEG(4)=.587317954286617
         WLEG(4)=.203167426723066
         XLEG(5)=.36783149899818
         WLEG(5)=.233492536538355
         XLEG(6)=.125233408511469
         WLEG(6)=.249147045813403
      ELSE IF (NLEG.EQ.16) THEN
         XLEG(1)=.98940093499165
         WLEG(1)=.027152459411754    !NLEG=16
         XLEG(2)=.944575023073233
         WLEG(2)=.062253523938648
         XLEG(3)=.865631202387832
         WLEG(3)=.095158511682493
         XLEG(4)=.755404408355003
         WLEG(4)=.124628971255534
         XLEG(5)=.617876244402644
         WLEG(5)=.149595988816577
         XLEG(6)=.458016777657227
         WLEG(6)=.169156519395003
         XLEG(7)=.281603550779259
         WLEG(7)=.182603415044924
         XLEG(8)=.095012509837637
         WLEG(8)=.189450610455069
      ELSE IF (NLEG.EQ.20) THEN
         XLEG(1)=.993128599185094
         WLEG(1)=.017614007139152    !NLEG=20
         XLEG(2)=.963971927277913
         WLEG(2)=.040601429800386
         XLEG(3)=.912234428251325
         WLEG(3)=.062672048334109
         XLEG(4)=.839116971822218
         WLEG(4)=.083276741576704
         XLEG(5)=.74633190646015
         WLEG(5)=.10193011981724
         XLEG(6)=.636053680726515
         WLEG(6)=.118194531961518
         XLEG(7)=.510867001950827
         WLEG(7)=.131688638449176
         XLEG(8)=.373706088715419
         WLEG(8)=.142096109318382
         XLEG(9)=.227785851141645
         WLEG(9)=.149172986472603
         XLEG(10)=.076526521133497
         WLEG(10)=.152753387130725
      ELSE IF (NLEG.EQ.24) THEN
         XLEG(1)=.995187219997021
         WLEG(1)=.012341229799987    !NLEG=24
         XLEG(2)=.974728555971309
         WLEG(2)=.028531388628933
         XLEG(3)=.938274552002732
         WLEG(3)=.044277438817419
         XLEG(4)=.886415527004401
         WLEG(4)=.059298584915436
         XLEG(5)=.820001985973902
         WLEG(5)=.07334648141108
         XLEG(6)=.740124191578554
         WLEG(6)=.086190161531953
         XLEG(7)=.648093651936975
         WLEG(7)=.097618652104113
         XLEG(8)=.545421471388839
         WLEG(8)=.107444270115965
         XLEG(9)=.433793507626045
         WLEG(9)=.115505668053725
         XLEG(10)=.315042679696163
         WLEG(10)=.121670472927803
         XLEG(11)=.191118867473616
         WLEG(11)=.125837456346828
         XLEG(12)=.064056892862605
         WLEG(12)=.127938195346752
      ELSE IF (NLEG.EQ.32) THEN
         XLEG(1)=.997263861849481
         WLEG(1)=.00701861000947     !NLEG=32
         XLEG(2)=.985611511545268
         WLEG(2)=.016274394730905
         XLEG(3)=.964762255587506
         WLEG(3)=.025392065309262
         XLEG(4)=.934906075937739
         WLEG(4)=.034273862913021
         XLEG(5)=.896321155766052
         WLEG(5)=.042835898022226
         XLEG(6)=.849367613732569
         WLEG(6)=.050998059262376
         XLEG(7)=.794483795967942
         WLEG(7)=.058684093478535
         XLEG(8)=.732182118740289
         WLEG(8)=.065822222776361
         XLEG(9)=.663044266930215
         WLEG(9)=.072345794108848
         XLEG(10)=.587715757240762
         WLEG(10)=.07819389578707
         XLEG(11)=.506899908932229
         WLEG(11)=.083311924226946
         XLEG(12)=.421351276130635
         WLEG(12)=.087652093004403
         XLEG(13)=.331868602282127
         WLEG(13)=.091173878695763
         XLEG(14)=.239287362252137
         WLEG(14)=.093844399080804
         XLEG(15)=.144471961582796
         WLEG(15)=.095638720079274
         XLEG(16)=.048307665687738
         WLEG(16)=.096540088514727
      ELSE IF (NLEG.EQ.40) THEN
         XLEG(1)=.998237709710559
         WLEG(1)=.004521277098533    !NLEG=40
         XLEG(2)=.990726238699457
         WLEG(2)=.010498284531152
         XLEG(3)=.977259949983774
         WLEG(3)=.016421058381907
         XLEG(4)=.957916819213791
         WLEG(4)=.022245849194166
         XLEG(5)=.932812808278676
         WLEG(5)=.027937006980023
         XLEG(6)=.902098806968874
         WLEG(6)=.033460195282547
         XLEG(7)=.865959503212259
         WLEG(7)=.038782167974472
         XLEG(8)=.824612230833311
         WLEG(8)=.043870908185673
         XLEG(9)=.778305651426519
         WLEG(9)=.048695807635072
         XLEG(10)=.727318255189927
         WLEG(10)=.053227846983936
         XLEG(11)=.671956684614179
         WLEG(11)=.057439769099391
         XLEG(12)=.61255388966798
         WLEG(12)=.061306242492928
         XLEG(13)=.549467125095128
         WLEG(13)=.064804013456601
         XLEG(14)=.483075801686178
         WLEG(14)=.067912045815233
         XLEG(15)=.413779204371605
         WLEG(15)=.070611647391286
         XLEG(16)=.341994090825758
         WLEG(16)=.072886582395804
         XLEG(17)=.268152185007253
         WLEG(17)=.074723169057968
         XLEG(18)=.192697580701371
         WLEG(18)=.076110361900626
         XLEG(19)=.116084070675255
         WLEG(19)=.077039818164247
         XLEG(20)=.03877241750605
         WLEG(20)=.077505947978424
      ELSE IF (NLEG.EQ.48) THEN
         XLEG(1)=.998771007252426
         WLEG(1)=.003153346052305     !NLEG=48
         XLEG(2)=.99353017226635
         WLEG(2)=.007327553901276
         XLEG(3)=.984124583722826
         WLEG(3)=.011477234579234
         XLEG(4)=.970591592546247
         WLEG(4)=.015579315722943
         XLEG(5)=.95298770316043
         WLEG(5)=.019616160457355
         XLEG(6)=.931386690706554
         WLEG(6)=.023570760839324
         XLEG(7)=.905879136715569
         WLEG(7)=.027426509708356
         XLEG(8)=.876572020274247
         WLEG(8)=.031167227832798
         XLEG(9)=.843588261624393
         WLEG(9)=.03477722256477
         XLEG(10)=.807066204029442
         WLEG(10)=.03824135106583
         XLEG(11)=.76715903251574
         WLEG(11)=.041545082943464
         XLEG(12)=.724034130923814
         WLEG(12)=.044674560856694
         XLEG(13)=.677872379632663
         WLEG(13)=.04761665849249
         XLEG(14)=.628867396776513
         WLEG(14)=.050359035553854
         XLEG(15)=.577224726083972
         WLEG(15)=.052890189485193
         XLEG(16)=.523160974722233
         WLEG(16)=.055199503699984
         XLEG(17)=.466902904750958
         WLEG(17)=.057277292100403
         XLEG(18)=.408686481990716
         WLEG(18)=.059114839698395
         XLEG(19)=.34875588629216
         WLEG(19)=.060704439165893
         XLEG(20)=.287362487355455
         WLEG(20)=.062039423159892
         XLEG(21)=.224763790394689
         WLEG(21)=.063114192286254
         XLEG(22)=.161222356068891
         WLEG(22)=.063924238584648
         XLEG(23)=.097004699209462
         WLEG(23)=.06446616443595
         XLEG(24)=.032380170962869
         WLEG(24)=.064737696812683
      ELSE
         NLBAD=.TRUE.     !if NLEG is a disallowed value
      ENDIF
C
      IF (.NOT. NLBAD) THEN
         DO 100 ILEG=1,NLEG/2            !since the weights and abscissa
            XLEG(NLEG-ILEG+1)=-XLEG(ILEG)!are even and odd functions
            WLEG(NLEG-ILEG+1)=WLEG(ILEG) !functions respectively
100      CONTINUE
      ENDIF
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE INIT
C initializes constants, displays header screen,
C initializes arrays for input parameters
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'IO.ALL'
      INCLUDE 'MENU.ALL'
      INCLUDE 'PARAM.E4'
C Local parameters:
      CHARACTER*80 DESCRP          !program description
      DIMENSION DESCRP(20)
      INTEGER NHEAD,NTEXT,NGRAPH   !number of lines for each description
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      CALL SETUP                !get environment parameters
C
C     display header screen
      DESCRP(1)= 'EXAMPLE 4'
      DESCRP(2)= 'Born and Eikonal Approximations'
      DESCRP(3)= 'to Quantum Scattering'
      NHEAD=3
C
C     text output description
      DESCRP(4)= 'angle, momentum transfer, Born and Eikonal '
     +   //'differential cross sections,'
      DESCRP(5)= 'and Born, Eikonal, and optical theorem '
     +   //'total cross section'
      NTEXT=2
C
C     graphics output description
      DESCRP(6)= 'differential cross section vs. theta'
      NGRAPH=1
C
      CALL HEADER(DESCRP,NHEAD,NTEXT,NGRAPH)
C
C     set constant values
      PI=3.1415926
      SQHALF=SQRT(0.5)
      E2=14.409                      !electron charge, squared
      RMAX=2.0
      HBARM=7.6359                   !hbar**2/mass electron
C
      CALL MENU                      !setup constant part of menu
C
      MTYPE(13)=MTITLE
      MPRMPT(13)='Potential Function Options:'
      MLOLIM(13)=2
      MHILIM(13)=1
C
      MTYPE(14)=MTITLE
      MPRMPT(14)='1) Lenz-Jensen Potential: electron & neutral atom'
      MLOLIM(14)=0
      MHILIM(14)=0
C
      MTYPE(15)=MTITLE
      MPRMPT(15)='2) Square Well'
      MLOLIM(15)=0
      MHILIM(15)=0
C
      MTYPE(16)=MTITLE
      MPRMPT(16)='3) Gaussian Well'
      MLOLIM(16)=0
      MHILIM(16)=1
C
      MTYPE(17)=MCHOIC
      MPRMPT(17)='Enter Choice'
      MTAG(17)='18 20 20'
      MLOLIM(17)=1
      MHILIM(17)=3
      MINTS(17)=1
      MREALS(17)=1.
C
      MTYPE(18)=NUM
      MPRMPT(18)='Enter charge of the atomic nucleus'
      MTAG(18)='Z'
      MLOLIM(18)=1
      MHILIM(18)=108
      MINTS(18)=4
C
      MTYPE(19)=SKIP
      MREALS(19)=21
C
      MTYPE(20)=FLOAT
      MPRMPT(20)='Enter Vzero (eV)'
      MTAG(20)='Vzero (eV)'
      MLOLIM(20)=0.0
      MHILIM(20)=5000.
      MREALS(20)=20.0
C
      MTYPE(21)=FLOAT
      MPRMPT(21)='Enter Energy (eV)'
      MTAG(21)='Energy (eV)'
      MLOLIM(21)=0.0
      MHILIM(21)=5.0E+06
      MREALS(21)=20.0
C
      MTYPE(22)=SKIP
      MREALS(22)=35
C
      MTYPE(38)=NUM
      MPRMPT(38)='Number of quadrature points'
      MTAG(38)='number of quadrature points'
      MLOLIM(38)=2
      MHILIM(38)=48
      MINTS(38)=20
C
      MTYPE(39)=SKIP
      MREALS(39)=60
C
      MSTRNG(MINTS(75))= 'exmpl4.txt'
C
      MTYPE(76)=SKIP
      MREALS(76)=80.
C
      MSTRNG(MINTS(86))= 'exmpl4.grf'
C
      MTYPE(87)=SKIP
      MREALS(87)=90.
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE PARAM
C gets parameters from screen
C ends program on request
C closes old files
C maps menu variables to program variables
C opens new files
C calculates all derivative parameters
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'MENU.ALL'
      INCLUDE 'IO.ALL'
      INCLUDE 'PARAM.E4'
C Local Variables:
      LOGICAL NLBAD                  !allowed value of nleg?
C map between menu items and parameters
      INTEGER IPOT,IZ,IVZERO,IE,INLEG
      PARAMETER (IPOT   = 17 )
      PARAMETER (IZ     = 18 )
      PARAMETER (IVZERO = 20 )
      PARAMETER (IE     = 21 )
      PARAMETER (INLEG  = 38 )
C Functions:
      INTEGER GETINT                 !gets integer value from screen
      LOGICAL LOGCVT                 !converts 1 and 0 to true and false
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     get input from terminal
      CALL CLEAR
      CALL ASK(1,ISTOP)
C
C     stop program if requested
      IF (MREALS(IMAIN) .EQ. STOP) CALL FINISH
C
C     close files if necessary
      IF (TNAME .NE. MSTRNG(MINTS(ITNAME)))
     +     CALL FLCLOS(TNAME,TUNIT)
      IF (GNAME .NE. MSTRNG(MINTS(IGNAME)))
     +     CALL FLCLOS(GNAME,GUNIT)
C
C     physical and numerical parameters
      POT=MINTS(IPOT)
      Z=MINTS(IZ)
      VZERO=MREALS(IVZERO)
      E=MREALS(IE)
      NLEG=MINTS(INLEG)
C
C     derived constants
      K=SQRT(2*E/HBARM)
      IF (POT .EQ. LENZ) THEN
         RCUT=1.
         Z6=Z**.166667
         R1S=.529/Z
      ELSE
         RCUT=2.
      END IF
C
C     find weights and abscissae for Gauss-Legendre integration
      CALL QUAD(NLBAD)
100   IF (NLBAD) THEN
         WRITE (OUNIT,*) ' Allowed values for quadrature points are ',
     +                   '2 3 4 5 6 8 10 12 16 20 24 32 40 48'
         NLEG=GETINT(20,2,48,'Enter new number of quadrature points')
         MINTS(INLEG)=NLEG
         CALL QUAD(NLBAD)
      GOTO 100
      END IF
      CALL CLEAR
C
C     text output
      TTERM=LOGCVT(MINTS(ITTERM))
      TFILE=LOGCVT(MINTS(ITFILE))
      TNAME=MSTRNG(MINTS(ITNAME))
C
C     graphics output
      GTERM=LOGCVT(MINTS(IGTERM))
      GHRDCP=LOGCVT(MINTS(IGHRD))
      GFILE=LOGCVT(MINTS(IGFILE))
      GNAME=MSTRNG(MINTS(IGNAME))
C
C     open files
      IF (TFILE) CALL FLOPEN(TNAME,TUNIT)
      IF (GFILE) CALL FLOPEN(GNAME,GUNIT)
      !files may have been renamed
      MSTRNG(MINTS(ITNAME))=TNAME
      MSTRNG(MINTS(IGNAME))=GNAME
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE PRMOUT(MUNIT,NLINES)
C outputs parameters to MUNIT
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
       INCLUDE 'IO.ALL'
       INCLUDE 'PARAM.E4'
C Passed variables:
       INTEGER MUNIT            !unit number for output (input)
       INTEGER NLINES           !number of lines written so far (I/O)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
       IF (MUNIT .EQ. OUNIT) CALL CLEAR
C
       WRITE (MUNIT,2)
       WRITE (MUNIT,4)
       WRITE (MUNIT,6) E
       WRITE (MUNIT,8) NLEG
C
       IF (POT .EQ. LENZ) THEN
           WRITE (MUNIT,10) Z
       ELSE IF (POT .EQ. SQUARE) THEN
           WRITE (MUNIT,12) VZERO
       ELSE IF (POT .EQ. GAUSS) THEN
           WRITE (MUNIT,14) VZERO
       END IF
       WRITE (MUNIT,15)
C
C      different header for text and graphics files
       IF (MUNIT .EQ. GUNIT) THEN
         WRITE (MUNIT,2)
       ELSE
         WRITE (MUNIT,2)
         WRITE (MUNIT,16)
         WRITE (MUNIT,17)
         WRITE (MUNIT,18)
       END IF
C
       NLINES=10
C
2      FORMAT (' ')
4      FORMAT (' Output from example 4: Born and eikonal '
     +         'approximations to quantum scattering')
6      FORMAT (' Energy (eV) =', 1PE10.3)
8      FORMAT (' Number of quadrature points = ' , I2)
10     FORMAT (' Lenz Jensen potential with Z = ', I3)
12     FORMAT (' Square well potential with Vzero = ' 1PE10.3)
14     FORMAT (' Gaussian potential with Vzero = ' 1PE10.3)
15     FORMAT (' Theta is in degrees')
16     FORMAT (11X,'Theta',13X,'Q',14X,'Born',14X,'Eikonal')
17     FORMAT (10X,'degrees',11X,'A*-1',12X,'A**2',14X,'  A**2 ')
18     FORMAT (10X,'-------',11X,'----',12X,'----',14X,'-------')
C
       RETURN
       END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE TXTOUT(MUNIT,DEGREE,Q,SIGB,SIGE,NLINES)
C writes out differential cross section at each angle
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'IO.ALL'
      INCLUDE 'PARAM.E4'
C Input variables:
      INTEGER MUNIT           !output unit specifier
      INTEGER NLINES          !number of lines printed to screen (I/O)
      REAL DEGREE,Q           !angle and momentum transfer
      REAL SIGB,SIGE          !Born and eikonal diff cross section
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     if screen is full, clear and type headings again
      IF ((MOD(NLINES,TRMLIN-5) .EQ. 0)
     +                          .AND. (MUNIT .EQ. OUNIT)) THEN
         CALL PAUSE('to continue...',1)
         CALL CLEAR
         WRITE (MUNIT,16)
         WRITE (MUNIT,17)
         WRITE (MUNIT,18)
         WRITE (MUNIT,2)
         NLINES=NLINES+3
      END IF
C
      WRITE (MUNIT,20) DEGREE,Q,SIGB,SIGE
C
C     keep track of printed lines only for terminal output
      IF (MUNIT .EQ. OUNIT) NLINES=NLINES+1
C
20    FORMAT(9X,F7.2,9X,F7.2,9X,1PE10.3,9X,1PE10.3)
2     FORMAT (' ')
16    FORMAT (11X,'Theta',13X,'Q',14X,'Born',14X,'Eikonal')
17    FORMAT (10X,'degrees',11X,'A*-1',12X,'A**2',14X,'  A**2 ')
18    FORMAT (10X,'-------',11X,'----',12X,'----',14X,'-------')
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE TOTOUT(MUNIT,THTCUT,SIGBT,SIGET,SIGOPT)
C writes out total cross section to MUNIT
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'IO.ALL'
      INCLUDE 'PARAM.E4'
C Input variables:
      INTEGER MUNIT               !output unit specifier
      REAL THTCUT                 !theta cut
      REAL SIGBT,SIGET,SIGOPT     !total cross section with diff methods
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      WRITE (MUNIT,*) ' '
      WRITE (MUNIT,10) THTCUT*180/PI
      WRITE (MUNIT,20) SIGBT
      WRITE (MUNIT,30) SIGET
      WRITE (MUNIT,40) SIGOPT
C
10    FORMAT ('                   theta cut = ', F7.2,' degrees')
20    FORMAT ('            Born sigma total =',1PE10.3,' Angstroms**2')
30    FORMAT ('         Eikonal sigma total =',1PE10.3,' Angstroms**2')
40    FORMAT (' Optical theorem sigma total =',1PE10.3,' Angstroms**2')
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE GRFOUT(DEVICE)
C graphs differential cross section vs. angle on a semi-log scale
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables
      INCLUDE 'IO.ALL'
      INCLUDE 'PARAM.E4'
      INCLUDE 'GRFDAT.ALL'
C Input variables:
      INTEGER DEVICE         !which device is being used?
C Local variables
      INTEGER ILEG           !indexes angle
      INTEGER EXPMAX,EXPMIN  !min and max exp for diff cross section
      CHARACTER*9 CE         !E as a character string
      REAL DEGREE(96)        !angle
      REAL SIGE(96)          !eikonal differential cross section
      REAL SIGB(96)          !Born differential cross section
      INTEGER LEN            !string length
      INTEGER SCREEN         !send to terminal
      INTEGER PAPER          !make a hardcopy
      INTEGER FILE           !send to a file
      COMMON/RESULT/DEGREE,SIGE,SIGB
      DATA SCREEN,PAPER,FILE/1,2,3/
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     messages for the impatient
      IF (DEVICE .NE. SCREEN) WRITE (OUNIT,100)
C
C     calculate parameters for graphing
      IF (DEVICE .NE. FILE) THEN
          NPLOT=1                        !how many plots?
          IPLOT=1
C
          YMAX=0.                        !find limits on data points
          YMIN=SIGB(1)
          DO 20 ILEG=1,2*NLEG
             IF (SIGB(ILEG) .GT. YMAX) YMAX=SIGB(ILEG)
             IF (SIGE(ILEG) .GT. YMAX) YMAX=SIGE(ILEG)
             IF (SIGB(ILEG) .LT. YMIN) YMIN=SIGB(ILEG)
             IF (SIGE(ILEG) .LT. YMIN) YMIN=SIGE(ILEG)
20        CONTINUE
C         find integer limits on exponent
          EXPMAX=INT(LOG10(YMAX))
          IF (YMAX .GT. 1.) EXPMAX =EXPMAX+1
          EXPMIN=INT(LOG10(YMIN))
          IF (YMIN .LT. 1.) EXPMIN=EXPMIN-1
          YMAX=10.**EXPMAX
          YMIN=10.**EXPMIN
C
          XMIN=DEGREE(1)
          XMAX=DEGREE(2*NLEG)
          Y0VAL=XMIN
          X0VAL=YMIN
C
          NPOINT=2*NLEG
C
          ILINE=1                      !line and symbol styles
          ISYM=4
          IFREQ=1
          NXTICK=5
          NYTICK=EXPMAX-EXPMIN
          IF (NYTICK .GT. 8) THEN      !keep number of ticks small
             IF (MOD(NYTICK,2) .EQ. 0) THEN
                NYTICK=NYTICK/2
             ELSE
                NYTICK=8
             END IF
          END IF
C
          CALL CONVRT(E,CE,LEN)                      !titles and labels
          INFO = 'Born(X) and Eikonal(0) Approximations'
          LABEL(1)= 'Angle (Degrees)'
          IF (POT .EQ. LENZ) THEN
            TITLE = ' Lenz-Jensen Potential, Energy (eV)='//CE
            LABEL(2)= 'Differential Cross Section (Angstroms**2)'
          ELSE IF (POT .EQ. SQUARE) THEN
            TITLE = 'Square Well Potential, Energy (eV)='//CE
            LABEL(2)= 'Differential Cross Section (Angstroms**2)'
          ELSE IF (POT .EQ. GAUSS) THEN
            TITLE = 'Gaussian Potential, Energy (eV)='//CE
            LABEL(2)= 'Differential Cross Section (Angstroms**2)'
          END IF
C
          CALL GTDEV(DEVICE)                   !device nomination
          IF (DEVICE .EQ. SCREEN) CALL GMODE   !change to graphics mode
          CALL LGLNAX                          !draw axes
      END IF
C
C     output results
      IF (DEVICE .EQ. FILE) THEN
          WRITE (GUNIT,16)
          WRITE (GUNIT,18)
          WRITE (GUNIT,70) (DEGREE(ILEG),SIGB(ILEG),SIGE(ILEG),
     +        ILEG=1,2*NLEG)
      ELSE
         CALL XYPLOT (DEGREE,SIGB)              !plot born
         ISYM=1
         CALL XYPLOT (DEGREE,SIGE)              !plot eikonal
      END IF
C
C     end graphing session
      IF (DEVICE .NE. FILE) CALL GPAGE(DEVICE)  !end graphics package
      IF (DEVICE .EQ. SCREEN) CALL TMODE        !switch to text mode
C
16    FORMAT (10X,'Theta',13X,'Born',14X,'Eikonal')
18    FORMAT (10X,'-----',13X,'----',14X,'-------')
70    FORMAT (9X,F7.2,9X,1PE10.3,9X,1PE10.3)
100   FORMAT (/,' Patience, please; output going to a file.')
C
      RETURN
      END


      SUBROUTINE A1(A, N, B)

      INTEGER I, N
      REAL B(N), A(N)

      DO i=2,N
         B(I) = (A(I) + A(I - 1)) / 2.0
      ENDDO

      END