module shadow_pre_sync_urgent

!
!  This module include code from URGENT, a code from  R.P.Walker and B.Diviacco
!  to compute Undulator Radiation properties.
!
!  Reference:
!          R.P. Walker and B. Diviacco,
!          URGENT-A computer program for calculating the undulator radiation
!          spectral, angular, polarization, and power density properties,
!          Rev. Sci. Instrum. 63, pp. 392-395, 1992.
!
!  Purpose:
!          The purpose of this module is to implement the photon angular
!          distribution as a function of the photon energy for an Undulator.
!          It is an alternative mechanism for creating a shadow3
!          undulator source, thus to be used instead the SHADOW's
!          undul_phot preprocessor.
!
!  History:
!         First version was created by Federico Zontone at ESRF in 1994
!         using Urgent code. The code cdf_z.f was used in SHADOW's
!         ESRF version for years, and has been proposed as an optional
!         module in shadow3.
!
!         In december 2013 M. Sanchez del Rio revisited the undulator codes
!         in SHADOW3 and converted cdf_z.f in a fortran 9x module urgent.F90
!         that is used in shadow3 (by default now).
!
!         The called subroutine is renamed from cdf_z to undul_phot_urgent
!         to be more consistemt with the names. In fact, this code calculates
!         the photon flux distributions and not the cdf (that is calculated
!         in the SHADOW preprocessor undul_cdf).
!
!         To convert cdf_z in a f9x module some changes have been done in the
!         code. Mainly the common blocks are now global variables, and some
!         variables have been renamed to avoid fortran reserved names and
!         conflict between global variables and variables in routines scope.
!         Also, all variables are declared (implicit none).
!         Most modification are in lowercase.
!
! Inputs:
!        Undulator inputs are read from files created by other
!        shadow3 prerocessors:
!
!        - epath.nml (written by shadow3/epath)
!        - uphot.nml (written by shadow3/undul_set)
!        - uphot.dat containing the (energy,theta,phi) grid
!                    (written by shadow3/undul_set)
!
! Outputs:
!        - uphot.dat the flux for different photon energies are appended
!                    in the uphot.dat file (binary). Note that this
!                    binary file can be converted to ascii output using
!                    shadow3/undul_phot_dump utility.
!
! TODO:
!         Continue cleaning the code:
!             - check and manage dimensions
!             - make variable declarations compatible with shadow3
!             - implement the full functionality of the main URGENT
!               (some functions are missing here).
!
!
    !---- Use Modules ----!

    ! for compatibility with shadow3 (just in case!)
    use, intrinsic :: ISO_C_BINDING

    !---- Variables ----!
    implicit none

    !C
    !C declarations
    !C

    double precision gamma1,K3,KX,KY,LAMDAR,len1
    double precision SINPHI(400),COSPHI(400)
    double precision DPHI,DALPHA
    double precision CODE(400)
    integer isg(400)
    integer NPHI1,NPHI2,NALPHA
    integer Nund

    double precision F3,APMIN,APMAX
    integer MODE,ICALC,IHARM,IANG
    double precision D,XPMIN,DXP,YPMIN,DYP,FAC
    integer NXP,NYP

    double precision E_MIN,DE
    double precision H(5000)
    double precision WMIN,DW
    integer NW

    double precision BRI1(101,10),BRI2(101,10)
    double precision BRI3(101,10),BRI0(101,10)
    double precision RAD1(51,51),RAD2(51,51)
    double precision RAD3(51,51),RAD0(51,51)
    integer I1(5001),I2(5001)
    integer L1,L2,L3,L4
    double precision SPEC1(5001),SPEC2(5001)
    double precision SPEC3(5001),SPEC0(5001)
    double precision WK(5001)

    integer maxx,maxy
    double precision jnx(1000),jny(1000)
    double precision j0x,j0y

!C
!C common/global block 1
!C
!         COMMON/INPUT/gamma1,K3,KX,KY,LAMDAR,len1,Nund
!
!C        COMMON/ANGLE/CODE(400),SINPHI(400),COSPHI(400),DPHI,DALPHA,
!C     $  ISG(400),NPHI1,NPHI2,NALPHA
!
!         COMMON/CONST/F3,APMIN,APMAX,MODE,ICALC,IHARM,IANG
!         COMMON/SCREEN/D,XPMIN,DXP,YPMIN,DYP,FAC,NXP,NYP
!         COMMON/SCALE/E_MIN,DE
!
!C         COMMON/CONVL/H(5001),WMIN,DW,NW
!
!C         COMMON/CALC/BRI1(101,101),BRI2(101,101),BRI3(101,101),
!C     $  BRI0(101,101),RAD1(51,51),RAD2(51,51),RAD3(51,51),
!C     $  RAD0(51,51),I1(5001),I2(5001),L1,L2,L3,L4,
!C     $  SPEC1(5001),SPEC2(5001),SPEC3(5001),SPEC0(5001),WK(5001)
!
!
!C
!C common/global block 2
!C
!C        COMMON/JDATA/JNX(1000),JNY(1000),J0X,J0Y,MAXX,MAXY
!C

    !---- Everything is private unless explicitly made public ----!
    private

    !---- List of public functions ----!
!    public ::
    !---- List of public overloaded functions ----!
    !---- List of public subroutines ----!
    public ::  undul_phot_urgent

 Contains

        subroutine undul_phot_urgent
        implicit none

        double precision PERIOD_1,KX_1,KY_1, ENERGY_1,CUR_1, DALPHA_1
        integer NPERIOD_1, NPHI_1, NE_1,NT_1,NP_1

        call GetFromNml(PERIOD_1,KX_1,KY_1,NPERIOD_1,ENERGY_1, &
        CUR_1,NPHI_1,DALPHA_1,NE_1,NT_1,NP_1)
        call cdf_z_calc(PERIOD_1,KX_1,KY_1,NPERIOD_1,ENERGY_1, &
        CUR_1,NPHI_1,DALPHA_1,NE_1,NT_1,NP_1)

        end subroutine undul_phot_urgent

!C
!C ***************************************************************************
!C
!C                             CDF_Z
!C
!C       A program to generate the CDF of the photons for SHADOW by
!C	calculating the flux and the degree of polarization at given
!C	polar angles (theta,phi) and energy.
!C
!C       Modified version of URGENT made by F. Zontone.
!C             Further modified my M. Sanchez del Rio to adapt to shadow3
!C
!C       Usage: to call in the SHADOW module "MAKE_ID", option 'undulator',
!C              as user's program.
!C
!C	INPUT:  i)  the input file UNDUL_Z.PAR with the undulator
!C		    parameters;
!C	OUTPUT: i)  the file for SHADOW uphot.dat used for generating
!C		    the CDF of the undulator radiation
!C
        SUBROUTINE CDF_Z_CALC(PERIOD_1,KX_1,KY_1,NPERIOD_1,ENERGY_1, &
        CUR_1,NPHI_1,DALPHA_1,NE_1,NT_1,NP_1)

        implicit none

        double precision PERIOD_1,KX_1,KY_1, ENERGY_1,CUR_1, DALPHA_1
        integer NPERIOD_1, NPHI_1, NE_1,NT_1,NP_1
        double precision ENER,THETA_S,PHI_S,RNO,POL_DEG

        double precision cur,domega,e1,energy,gk,k,k2
        double precision l1_s,lamda1,pd,period,ph_ang
        integer i,isign1,inc,idebug,ie,j,m,n,nomega,np_s,ne_s,nt_s
        integer nphi,nsig
        integer use_undulator_binary_file

        double precision ptot,phi,xe,xpc,xps,th_ang,ye,ypc,yps
        double precision pi

        DIMENSION ENER(NE_1),THETA_S(NT_1,NE_1),PHI_S(NP_1,NT_1,NE_1)
        DIMENSION RNO(NP_1,NT_1,NE_1),POL_DEG(NP_1,NT_1,NE_1)

        !DIMENSION ENER(51),THETA_S(31,51),PHI_S(31,31,51)
        !DIMENSION RNO(31,31,51),POL_DEG(31,31,51)
!C        IMPLICIT DOUBLE PRECISION (A-H,K,L,O-Z)
!C        INTEGER CODE, Nund
!C        COMMON/INPUT/gamma1,K3,KX,KY,LAMDAR,len1,Nund
!CCsrio        COMMON/ANGLE/CODE(400),SINPHI(400),COSPHI(400),DPHI,NPHI1,NPHI2,
!CCsrio     $  NALPHA,DALPHA,ISG(400)
!C        COMMON/ANGLE/CODE(400),SINPHI(400),COSPHI(400),DPHI,DALPHA,
!C     $  ISG(400),NPHI1,NPHI2,NALPHA
!C        COMMON/CONST/F3,APMIN,APMAX,MODE,ICALC,IHARM,IANG
!CCsrio        COMMON/SCREEN/D,XPMIN,DXP,NXP,YPMIN,DYP,NYP,FAC
!C        COMMON/SCREEN/D,XPMIN,DXP,YPMIN,DYP,FAC,NXP,NYP
!C        COMMON/SCALE/E_MIN,DE
!C        COMMON/CONVL/H(5001),WMIN,DW,NW
!C        COMMON/CALC/BRI1(101,101),BRI2(101,101),BRI3(101,101),
!C     $  BRI0(101,101),RAD1(51,51),RAD2(51,51),RAD3(51,51),
!C     $  RAD0(51,51),I1(5001),I2(5001),L1,L2,L3,L4,
!C     $  SPEC1(5001),SPEC2(5001),SPEC3(5001),SPEC0(5001),WK(5001)

        DATA PI/3.141592653589/,IDEBUG/0/
!C
!C       READ UNDULATOR PARAMETERS FROM A INPUT FILE
!C
!C
!C gets main inputs from arguments
!C
        PERIOD = period_1
        KX = kx_1
        KY = ky_1
        Nund = nperiod_1
        ENERGY = energy_1
        CUR = cur_1
        NPHI = nphi_1
        DALPHA = dalpha_1

!C
!C gets additional input from shadow namelists
!C
!C	OPEN(21,FILE='UNDUL_Z.PAR',STATUS='OLD')
!C	READ(21,*) PERIOD,KX,KY,N,ENERGY,CUR,NPHI,DALPHA
!C	CLOSE (21)
!C
!C	READ THE ANGLES FROM THE SHADOW BINARY FILE
!C
      use_undulator_binary_file = 0  ! from now, use ASCII files. If change, do the same in shadow_pre_sync.f90

      if (use_undulator_binary_file .eq. 1) then
          OPEN (10,FILE='uphot.dat',STATUS='UNKNOWN',FORM='UNFORMATTED')
          READ (10) NE_S,NT_S,NP_S
      else
          OPEN (10,FILE='uphot.dat',STATUS='UNKNOWN',FORM='FORMATTED')
          READ (10,*) NE_S,NT_S,NP_S
      endif

      IF ( (NE_1 .ne. NE_S) .or.  &
           (NT_1 .ne. NT_S) .or.  &
           (NP_1 .ne. NP_S) ) THEN
          write(*,*) "ERROR: Inconsistent dimensions: "
          write(*,*) "    NE_1,NE_S",NE_1,NE_S
          write(*,*) "    NT_1,NT_S",NT_1,NT_S
          write(*,*) "    NP_1,NP_S",NP_1,NP_S
          print *,'Error: CDF_Z_CALC'
          return
          ! STOP
      END IF

      if (use_undulator_binary_file .eq. 1) then
        DO M=1,NE_S
	        READ (10) ENER(M)
        END DO

        DO M=1,NE_S
	        DO J=1,NT_S
	            READ (10) THETA_S(J,M)
            END DO
        END DO

        DO M=1,NE_S
	        DO J=1,NT_S
	            DO I=1,NP_S
	                READ (10) PHI_S(I,J,M)
                END DO
            END DO
        END DO
      else
        DO M=1,NE_S
	        READ (10,*) ENER(M)
        END DO

        DO M=1,NE_S
	        DO J=1,NT_S
	            READ (10,*) THETA_S(J,M)
            END DO
        END DO

        DO M=1,NE_S
	        DO J=1,NT_S
	            DO I=1,NP_S
	                READ (10,*) PHI_S(I,J,M)
                END DO
            END DO
        END DO
      end if

!C
!C       CONSTANTS
!C
        gamma1=ENERGY/0.000511
        LAMDAR=PERIOD*1.0D+10/(2.0*gamma1*gamma1)
        K2=KX*KX+KY*KY
        K3=1.0+K2/2.0
        len1=Nund*PERIOD
        LAMDA1=LAMDAR*K3
        E1=12398.5/LAMDA1
        PTOT=0.0725*Nund*K2*ENERGY*ENERGY*CUR/PERIOD
        GK=0.0
        IF(KX.LT.1E-3.OR.KY.LT.1E-3)THEN
        IF(KX.LT.1E-3)K=KY
        IF(KY.LT.1E-3)K=KX
        GK=K*((K**6)+(24.*(K**4)/7.)+(4.*K*K)+(16./7.)) &
        /((1.+(K*K))**3.5)
        ENDIF
        IF(ABS(KX-KY).LT.1E-3)THEN
        K=KX
        GK=32.0/7.0*K/(1.0+K*K)**3.0
        ENDIF
        PD=0.1161*(ENERGY**4)*Nund*K*GK*CUR/PERIOD
!C
!C       DEFAULT CALCULATION
!C
        MODE=2
        ICALC=3
        IHARM=-1
        D=0.0
        XPS=0.0
        YPS=0.0
        NXP=0
        NYP=0
        IF(NPHI.EQ.0)NPHI=20
        IF(NSIG.EQ.0)NSIG=3
        IF(NALPHA.EQ.0)NALPHA=15
        IF(DALPHA.EQ.0.0)DALPHA=2.0
        nomega=0
        IF(NOMEGA.EQ.0)NOMEGA=16
        IF(DOMEGA.EQ.0.0)DOMEGA=2.0
!C
!C	ENERGY SCALE
!C
        DE=2.0*DOMEGA*E1/(NOMEGA*N)
!C
!C       ANGULAR (IANG=1) UNITS
!C
        IANG=1
        D=1.0
!C
!C       ERROR CHECK
!C
        write (*,*) "NXP,NYP,NPHI,NALPHA,NOMEGA: ",NXP,NYP,NPHI, &
      NALPHA,NOMEGA
        IF(NXP.LT.0.OR.NXP.GT.50.OR.NYP.LT.0.OR.NYP.GT.50)GOTO 900
        IF(NPHI.GT.100.OR.NALPHA.GT.100)GOTO 900
        IF(NOMEGA.GT.5000)GOTO 900
!C
!C	START CALCULATIONS
!C
        WRITE(6,500)
        DO M=1,NE_S
	   write(*,*) 'N of iteration in energy: ',M,' of ',NE_S
	   DO J=1,NT_S
	      DO I=1,NP_S
		 E_MIN=DBLE(ENER(M))
		 TH_ANG=DBLE(THETA_S(J,M))
		 PH_ANG=DBLE(PHI_S(I,J,M))
		 XPC=TH_ANG*DCOS(PH_ANG)*1D+03
		 YPC=TH_ANG*DSIN(PH_ANG)*1D+03
!C
!C       PINHOLE : DETERMINE MIN. AND MAX. EMISSION ANGLES WITHIN PINHOLE
!C
        	 XE=XPC*1.0D-03/D
        	 YE=YPC*1.0D-03/D
        	 APMAX=gamma1*gamma1*((XE*XE)+(YE*YE))
        	 APMIN=gamma1*gamma1*((XE*XE)+(YE*YE))
        	 IF(XPC.EQ.0.0.AND.YPC.EQ.0.0)THEN
          	 FAC=4.0
          	 XPMIN=0.0
          	 YPMIN=0.0
        	ELSE
          	 FAC=1.0
          	 XPMIN=XPC
          	 YPMIN=YPC
        	 ENDIF
        	NXP=1
        	NYP=1
!C
!C       SET UP ARRAY OF COSPHI AND SINPHI
!C
        	 NPHI1=(4*NPHI)
        	 NPHI2=NPHI+1
        	 INC=NPHI
        	 Isign1=1
        	 DPHI=2.0*PI/FLOAT(NPHI1)
        	DO 10 IE=1,NPHI1
        	 IF(IE.EQ.1)CODE(IE)=1
        	 IF(IE.NE.1)CODE(IE)=CODE(IE-1)+Isign1
        	 IF(IE.EQ.(INC+1))Isign1=-1
        	 IF(IE.EQ.((2*INC)+1))Isign1=1
        	 IF(IE.EQ.((3*INC)+1))Isign1=-1
        	 ISG(IE)=Isign1
        	 PHI=(IE-1)*DPHI
        	 SINPHI(IE)=DSIN(PHI)
        	 COSPHI(IE)=DCOS(PHI)
10      	CONTINUE
!C
!C       FACTOR TO SCALE FINAL RESULTS
!C
        	 F3=4.55D+07*Nund*Nund*gamma1*gamma1*CUR/(D*D)
!C
!C       CALL ANALYSIS PROGRAM
!C
     		 CALL SUB4
		 RAD0(1,1)=RAD0(1,1)*(1000/E_MIN)*1D06
		 RNO(I,J,M)=REAL(RAD0(1,1))
		 IF(RNO(I,J,M).LT.10.0) RNO(I,J,M)=1.0
		 L1_S=REAL(L1)
		 POL_DEG(I,J,M)=(1+L1_S)/2
      		 END DO
	   END DO
	END DO

	if (use_undulator_binary_file .eq. 1) then
	    DO M=1,NE_S
	       DO J=1,NT_S
	          DO I=1,NP_S
	             WRITE (10) RNO(I,J,M)
              END DO
           END DO
        END DO
	    DO M=1,NE_S
	       DO J=1,NT_S
	          DO I=1,NP_S
	             WRITE (10) POL_DEG(I,J,M)
              END DO
           END DO
        END DO
    else
	    DO M=1,NE_S
	       DO J=1,NT_S
	          DO I=1,NP_S
	             WRITE (10,*) RNO(I,J,M)
              END DO
           END DO
        END DO
	    DO M=1,NE_S
	       DO J=1,NT_S
	          DO I=1,NP_S
	             WRITE (10,*) POL_DEG(I,J,M)
              END DO
           END DO
        END DO
    end if

	CLOSE (10)
	write(*,*) 'Calculations have been successfully completed !'
	RETURN

        !STOP
900     WRITE(6,9000)
500     FORMAT('         ******  UNDUL_PHOT_URGENT - VERSION 1.3 - ******')
9000    FORMAT(//' *** INVALID INPUT PARAMETERS ***')
        END subroutine
!C
!C       ---------------
        SUBROUTINE SUB4
!C       ---------------
!C        IMPLICIT DOUBLE PRECISION (A-H,K,L,O-Z)
        implicit none

        integer i,ia,ne,ib,ic
        double precision ptot,a2max,a2min,alp,alp2,alp2i, cosph
        double precision e,lamda,power,r,radmax,s0,s1,s2,s3,sinph
        double precision xe1,xp,xpmm,ye1,yp,ypmm
        double precision pi,twopi,epi2
!        double precision sinc ! function
        DATA PI/3.141592653589/,TWOPI/6.283185307/,EPI2/78.95683521/

!C        INTEGER CODE,Nund

!C        COMMON/INPUT/gamma1,K3,KX,KY,LAMDAR,len1,Nund
!CCsrio        COMMON/ANGLE/CODE(400),SINPHI(400),COSPHI(400),DPHI,NPHI1,NPHI2,
!CCsrio     $  NALPHA,DALPHA,ISG(400)
!C        COMMON/ANGLE/CODE(400),SINPHI(400),COSPHI(400),DPHI,DALPHA,
!C     $  ISG(400),NPHI1,NPHI2,NALPHA
!C        COMMON/CONST/F3,APMIN,APMAX,MODE,ICALC,IHARM,IANG
!CCsrio        COMMON/SCREEN/D,XPMIN,DXP,NXP,YPMIN,DYP,NYP,FAC
!C        COMMON/SCREEN/D,XPMIN,DXP,YPMIN,DYP,FAC,NXP,NYP
!C	COMMON/SCALE/E_MIN,DE
!C        COMMON/CONVL/H(5001),WMIN,DW,NW
!C        COMMON/CALC/BRI1(101,101),BRI2(101,101),BRI3(101,101),
!C     $  BRI0(101,101),RAD1(51,51),RAD2(51,51),RAD3(51,51),
!C     $  RAD0(51,51),I1(5001),I2(5001),L1,L2,L3,L4,
!C     $  SPEC1(5001),SPEC2(5001),SPEC3(5001),SPEC0(5001),WK(5001)

!C
!C       ZERO EMITTANCE
!C       MODE  = 2 ANGULAR (IANG=1) DENSITY SPECTRUM
!C       ICALC = 3
!C
!C
!C       VARY PHOTON ENERGY
!C
        PTOT=0.0
        NE=1
        IA=NE
        E=E_MIN
        LAMDA=12398.5/E
        R=LAMDA/LAMDAR
        I1(IA)=0
        I2(IA)=0
        RADMAX=0.0
!C
!C       VARY POSITION IN PINHOLE
!C
        IB=NXP
        XPMM=XPMIN+((IB-1)*DXP)
        XP=XPMM/1000.0
        IC=NYP
        YPMM=YPMIN+((IC-1)*DYP)
        YP=YPMM/1000.0
        RAD1(IB,IC)=0.0
        RAD2(IB,IC)=0.0
        RAD3(IB,IC)=0.0
        RAD0(IB,IC)=0.0
!C
!C       FIND HARMONIC NO. CONTRIBUTING AT THE
!C       GIVEN WAVELENGTH AND PINHOLE POSITION
!C
        XE1=XP*gamma1/D
        YE1=YP*gamma1/D
        ALP2=(XE1*XE1)+(YE1*YE1)
        I=0
20      I=I+1
        ALP2I=(R*I)-K3
        A2MAX=ALP2I+(DALPHA*R/Nund)
        IF(A2MAX.LT.ALP2)GOTO 20
        A2MIN=ALP2I-(DALPHA*R/Nund)
        IF(A2MIN.GT.ALP2) GOTO 30
        IF(I1(IA).EQ.0)I1(IA)=I
        I2(IA)=I
        ALP=DSQRT(ALP2)
        COSPH=0.0
        SINPH=1.0
        IF(ALP.GT.1.0D-06)THEN
        COSPH=XE1/ALP
        SINPH=YE1/ALP
        ENDIF
        CALL BRIGHT(ALP,COSPH,SINPH,KX,KY,I,S0,S1,S2,S3)
        RAD1(IB,IC)=F3*S1*SINC(ALP2,ALP2I,R,Nund)
        RAD2(IB,IC)=F3*S2*SINC(ALP2,ALP2I,R,Nund)
        RAD3(IB,IC)=F3*S3*SINC(ALP2,ALP2I,R,Nund)
        RAD0(IB,IC)=F3*S0*SINC(ALP2,ALP2I,R,Nund)
!C
!C       PRINT IRRADIANCE DISTRIBUTION AT THE GIVEN WAVELENGTH
!C
        IF(RAD0(IB,IC).NE.0.0)THEN
        L1=RAD1(IB,IC)/RAD0(IB,IC)
        L2=RAD2(IB,IC)/RAD0(IB,IC)
        L3=RAD3(IB,IC)/RAD0(IB,IC)
        L4=SQRT(ABS(1.0-L1*L1-L2*L2-L3*L3))
        ELSE
        L1=0.0
        L2=0.0
        L3=0.0
        L4=0.0
        ENDIF
30      IF(RAD0(IB,IC).GT.RADMAX)RADMAX=RAD0(IB,IC)
        POWER=1.602D-16*RAD0(1,1)
        IF(RAD0(1,1).NE.0.0)THEN
          L1=RAD1(1,1)/RAD0(1,1)
          L2=RAD2(1,1)/RAD0(1,1)
          L3=RAD3(1,1)/RAD0(1,1)
          L4=SQRT(ABS(1.0-L1*L1-L2*L2-L3*L3))
          ELSE
          L1=0.0
          L2=0.0
          L3=0.0
          L4=0.0
          ENDIF
        IF(IA.EQ.1.OR.IA.EQ.NE)THEN
          PTOT=PTOT+(POWER/2.0)
        ELSE
          PTOT=PTOT+POWER
        ENDIF
        PTOT=PTOT*DE
        RETURN
        END subroutine
!C
!C       ----------------------------------------------------------
        SUBROUTINE BRIGHT(ALPHA,COSphi1,SINphi1,kx1,ky1,I,S0,S1,S2,S3)
!C       ----------------------------------------------------------
!Csrio        IMPLICIT DOUBLE PRECISION (A-H,K,O-Z)
!C        IMPLICIT DOUBLE PRECISION (A-H,K,L,O-Z)
        implicit none
        double precision ALPHA,COSphi1,SINphi1,kx1,ky1,S0,S1,S2,S3
        integer i

        double precision kmin

        DATA KMIN/0.001/
        IF(I.LE.0.OR.ALPHA.LT.0.0)GOTO 40
        IF(kx1.LT.KMIN.AND.ky1.LT.KMIN)GOTO 40
        IF(kx1.LT.KMIN.AND.ky1.GT.KMIN)GOTO 10
        IF(kx1.GT.KMIN.AND.ky1.LT.KMIN)GOTO 20
        IF(kx1.GT.KMIN.AND.ky1.GT.KMIN)GOTO 30
10      CALL BRIGH1(ALPHA,COSphi1,SINphi1,ky1,I,S0,S1,S2,S3)
        RETURN
20      CALL BRIGH1(ALPHA,SINphi1,-COSphi1,kx1,I,S0,S1,S2,S3)
        S1=-S1
        S2=-S2
        RETURN
30      CALL BRIGH3(ALPHA,COSphi1,SINphi1,kx1,ky1,I,S0,S1,S2,S3)
        RETURN
40      WRITE(6,9000)
        print *,'Error: BRIGHT'
        return
        !STOP
9000    FORMAT(//' *** INVALID INPUT PARAMETERS IN SUBROUTINE BRIGHT ***')
        END subroutine
!C
!C       -------------------------------------------------------
        SUBROUTINE BRIGH1(ALPHA,COSphi1,SINphi1,K,I,S0,S1,S2,S3)
!C       -------------------------------------------------------
!C        IMPLICIT DOUBLE PRECISION (A-H,K,L,O-Z)

        implicit none

        double precision alpha,cosphi1,sinphi1,k,s0,s1,s2,s3
        integer i

        double precision tol1,tol2
        double precision a,a0,a1,axr,ayr
        integer nmax,n,n1,n2
        double precision sum1,sum2 ,x,y
!       double precision jx,jy ! functions
!C        integer maxx,maxy
!C        double precision jnx,jny,j0x,j0y
!C        COMMON/JDATA/JNX(1000),JNY(1000),J0X,J0Y,MAXX,MAXY
!C        include 'tmp.h'

        DATA NMAX/1000/,TOL1/1.0D-05/,TOL2/1.0D-05/
!C
!C       CALCULATE THE UNDULATOR RADIATION BRIGHTNESS FUNCTION
!C       FOR A PLANE TRAJECTORY
!C       USING THE BESSEL FUNCTION APPROXIMATION
!C
!C       CALCULATE VARIABLES X, Y
!C
        A=1.0+((K*K)/2.0)+(ALPHA*ALPHA)
        X=I*2.0*K*ALPHA*COSphi1/A
        Y=I*K*K/(4.0*A)
        IF(DABS(X).LT.TOL1)GOTO 10
!C
!C       CALCULATE A0, A1 IN THE GENERAL CASE
!C
        CALL JSET(JNX,J0X,X,TOL2,MAXX,NMAX)
        CALL JSET(JNY,J0Y,Y,TOL2,MAXY,NMAX)
        CALL JSUM1(X,Y,SUM1,SUM2,I,MAXX,MAXY)
        A0=SUM1
        A1=((2.0*I*SUM1)+(4.0*SUM2))/X
        GOTO 30
!C
!C       CALCULATE A0, A1 WHEN X = 0.0
!C
10      CALL JSET(JNY,J0Y,Y,TOL2,MAXY,NMAX)
        IF(((I+1)/2).GT.MAXY)RETURN
        IF(I.EQ.((I/2)*2))GOTO 20
        N1=(-I-1)/2
        N2=(-I+1)/2
        A0=0.0
        A1=JY(N1)+JY(N2)
        GOTO 30
20      N=-I/2
        A0=JY(N)
        A1=0.0
!C
!C       CALCULATE STOKES PARAMETER
!C
30      AXR=2.0*I/A*(A0*ALPHA*COSphi1-K*A1/2.0)
        AYR=2.0*I/A*(A0*ALPHA*SINphi1)
        S0=AXR*AXR+AYR*AYR
        S1=AXR*AXR-AYR*AYR
        S2=2.0*AXR*AYR
        S3=0.0
        RETURN
        END subroutine
!C
!C       -----------------------------------------------------------
        SUBROUTINE BRIGH3(ALPHA,COSphi1,SINphi1,kx1,ky1,I,S0,S1,S2,S3)
!C       -----------------------------------------------------------
!Csrio        IMPLICIT DOUBLE PRECISION (A-H,J,K,O-Z)

        implicit none

        double precision alpha,cosphi1,sinphi1,kx1,ky1,s0,s1,s2,s3
        integer i

        integer nmax
        double precision tol1,tol2
        integer q
        integer n,n1,n2,n3
        double precision sum1,sum2 ,x,y
        double precision s0r,s0i,s1r,s1i,sm1r,sm1i
        double precision a,phi,axi,axr,ayi,ayr
!       double precision jx,jy ! functions
!C        double precision jnx,jny,j0x,j0y
!C        INTEGER Q
!C        COMMON/JDATA/JNX(1000),JNY(1000),J0X,J0Y,MAXX,MAXY
!C        include 'tmp.h'

        DATA NMAX/1000/,TOL1/1.0D-05/,TOL2/1.0D-05/

!C
!C       CALCULATE THE UNDULATOR RADIATION BRIGHTNESS FUNCTION
!C       FOR A GENERAL ELLIPTICAL/HELICAL TRAJECTORY
!C       USING THE BESSEL FUNCTION APPROXIMATION
!C
        S0R =0.0
        S0I =0.0
        S1R =0.0
        S1I =0.0
        SM1R=0.0
        SM1I=0.0
!C
!C       CALCULATE VARIABLES X, Y, PHI
!C
        A=1.0+((kx1*kx1)/2.0)+((ky1*ky1)/2.0)+(ALPHA*ALPHA)
        X=I*2.0*ALPHA*DSQRT(((kx1*SINphi1)**2)+((ky1*COSphi1)**2))/A
        Y=I*((ky1*ky1)-(kx1*kx1))/(4.0*A)
        PHI=DATAN2((kx1*SINphi1),(ky1*COSphi1))
        IF(X.LT.TOL1.AND.DABS(Y).LT.TOL1)GOTO 30
        IF(X.LT.TOL1)GOTO 10
        IF(DABS(Y).LT.TOL1)GOTO 20
!C
!C       SET UP BESSEL FUNCTIONS IN THE GENERAL CASE
!C
        CALL JSET(JNX,J0X,X,TOL2,MAXX,NMAX)
        CALL JSET(JNY,J0Y,Y,TOL2,MAXY,NMAX)
!C
!C       DO THE SUMS
!C
        Q=0
        CALL JSUM2(S0R,S0I,PHI,I,Q)
        Q=-1
        CALL JSUM2(SM1R,SM1I,PHI,I,Q)
        Q=1
        CALL JSUM2(S1R,S1I,PHI,I,Q)
        GOTO 40
!C
!C       CALCULATE S0,S1,SM1 WHEN X = 0.0
!C
10      CALL JSET(JNY,J0Y,Y,TOL2,MAXY,NMAX)
        IF(I.EQ.((I/2)*2))GOTO 15
        N1=(-I-1)/2
        N2=(-I+1)/2
        S1R =JY(N1)
        SM1R=JY(N2)
        GOTO 40
15      N=-I/2
        S0R =JY(N)
        GOTO 40
!C
!C       CALCULATE S0,S1,SM1 WHEN Y = 0.0
!C
20      N1=I
        N2=I+1
        N3=I-1
        CALL JSET(JNX,J0X,X,TOL2,MAXX,NMAX)
        S0R = DCOS(N1*PHI)*JX(N1)
        S0I =-DSIN(N1*PHI)*JX(N1)
        S1R = DCOS(N2*PHI)*JX(N2)
        S1I =-DSIN(N2*PHI)*JX(N2)
        SM1R= DCOS(N3*PHI)*JX(N3)
        SM1I=-DSIN(N3*PHI)*JX(N3)
        GOTO 40
!C
!C       CALCULATE S0,S1,SM1 WHEN X = 0.0 AND Y = 0.0
!C
30      IF(I.EQ.1)SM1R=1.0
!C
!C       CALCULATE STOKES PARAMETER
!C
40      AXR=((2.0*S0R*ALPHA*COSphi1)-(ky1*(S1R+SM1R)))*I/A
        AXI=((2.0*S0I*ALPHA*COSphi1)-(ky1*(S1I+SM1I)))*I/A
        AYR=((2.0*S0R*ALPHA*SINphi1)+(kx1*(S1I-SM1I)))*I/A
        AYI=((2.0*S0I*ALPHA*SINphi1)-(kx1*(S1R-SM1R)))*I/A
        S0=AXR*AXR+AXI*AXI+AYR*AYR+AYI*AYI
        S1=AXR*AXR+AXI*AXI-AYR*AYR-AYI*AYI
        S2=2.0*(AXR*AYR+AXI*AYI)
        S3=2.0*(AXI*AYR-AXR*AYI)
        RETURN
        END subroutine
!C
!C       --------------------------------------
        SUBROUTINE JSUM1(X,Y,S1,S2,I,maxx1,maxy1)
!C       --------------------------------------
!Csrio        IMPLICIT DOUBLE PRECISION (A-H,J,O-Z)

        implicit none

        double precision x,y,s1,s2
        integer i,maxx1,maxy1

!        double precision jx,jy  ! functions
        double precision sign1,j1,j2,j3
        integer n,n1,n2

!C
!C       CALCULATE SUMS S1 AND S2
!C
        S1=0.0
        IF(I.LE.maxx1)S1=JY(0)*JX(I)
        S2=0.0
        sign1=1.0
        DO 10 N=1,maxy1
        sign1=-sign1
        N1=(2*N)+I
        N2=(-2*N)+I
        J1=JY(N)
        J2=JX(N1)
        J3=JX(N2)
        S1=S1+(J1*(J2+(J3*sign1)))
        S2=S2+(N*J1*(J2-(J3*sign1)))
10      CONTINUE
        RETURN
        END subroutine
!C
!C       ------------------------------
        SUBROUTINE JSUM2(SR,SI,PHI,I,Q)
!C       ------------------------------
!Csrio        IMPLICIT DOUBLE PRECISION (A-H,J,K,O-Z)

        implicit none

        double precision sr,si,phi
        integer i,q

!       double precision jx,jy  ! functions
        double precision f
        integer n,p

!C        DOUBLE PRECISION jnx,jny,j0x,j0y
!C        COMMON/JDATA/JNX(1000),JNY(1000),J0X,J0Y,MAXX,MAXY
!C        include 'tmp.h'

        SR=0.0
        SI=0.0
        DO 10 P=-MAXY,MAXY
        N=I+(2*P)+Q
        IF(IABS(N).GT.MAXX)GOTO 10
        F=JX(N)*JY(P)
        SR=SR+(DCOS(N*PHI)*F)
        SI=SI-(DSIN(N*PHI)*F)
10      CONTINUE
        RETURN
        END subroutine
!C
!C       -----------------------------
        double precision FUNCTION SINC(ALP2,ALP2I,R,N)
!C       -----------------------------
!C        IMPLICIT DOUBLE PRECISION (A-H,K,L,O-Z)
        implicit none
        double precision alp2,alp2i,r
        integer n

        double precision x,pi

        DATA PI/3.141592653589/
!C
!C       CALCULATE THE LINESHAPE FUNCTION
!C
        SINC=1.0
        X=N*PI*(ALP2-ALP2I)/R
        IF(DABS(X).LT.1.0D-06)RETURN
        SINC=DSIN(X)/X
        SINC=SINC*SINC
        RETURN
        END function
!C
!C       --------------
        double precision FUNCTION JX(N)
!C       --------------
!Csrio        IMPLICIT DOUBLE PRECISION (A-H,J,O-Z)

        implicit none
        integer n
        integer n1
        double precision sign1

!C        DOUBLE PRECISION jnx,jny,j0x,j0y
!C        DOUBLE PRECISION jx
!C        COMMON/JDATA/JNX(1000),JNY(1000),J0X,J0Y,MAXX,MAXY
!C        include 'tmp.h'

        n1 = -1111
        JX=0.0
!C        IF(IABS(N).GT.MAXX)RETURN
        IF(IABS(N).GT.MAXX) GO TO 8000
        IF(N.NE.0)GOTO 10
        JX=J0X
!C        RETURN
        GO TO 8000
10      sign1=1.0
        N1=N
        IF(N.GT.0)GOTO 20
        N1=-N
        IF(N1.NE.((N1/2)*2))sign1=-1.0
20      JX=JNX(N1)*sign1
8000    continue
        RETURN
        END function
!C
!C       --------------
        double precision FUNCTION JY(N)
!C       --------------
!Csrio        IMPLICIT DOUBLE PRECISION (A-H,J,O-Z)

        implicit none
        integer n
        integer n1
        double precision sign1

!C        DOUBLE PRECISION jnx,jny,j0x,j0y
!C        DOUBLE PRECISION jy
!C        COMMON/JDATA/JNX(1000),JNY(1000),J0X,J0Y,MAXX,MAXY

        JY=0.0
        IF(IABS(N).GT.MAXY)RETURN
        IF(N.NE.0)GOTO 10
        JY=J0Y
        RETURN
10      sign1=1.0
        N1=N
        IF(N.GT.0)GOTO 20
        N1=-N
        IF(N1.NE.((N1/2)*2))sign1=-1.0
20      JY=JNY(N1)*sign1
        RETURN
        END function
!C
!C       ----------------------------------------
        SUBROUTINE JSET(jnx1,j0x1,X0,TOL,max11,NMAX)
!C       ----------------------------------------
!Csrio        IMPLICIT DOUBLE PRECISION (A-H,J,O-Z)

        implicit none
        double precision jnx1,j0x1
        double precision x0,tol
        integer max11,nmax

        double precision bigno,bigni
        double precision bj,bjn,bjp,sign1,tox,x,sum1
        integer i,isum,m,n,n1

!C        DOUBLE PRECISION jnx,jny,j0x,j0y

        DIMENSION jnx1(1)
        DATA BIGNO/1.0D+10/,BIGNI/1.0D-10/
!C
!C       SET UP ARRAY OF BESSEL FUNCTIONS UP TO ORDER MAX
!C       SUCH THAT JMAX (X) < TOL AND MAX > X
!C       USING MILLER'S DOWNWARD RECURRENCE ALGORITHM
!C       MODIFIED FORM OF NUMERICAL RECIPIES ROUTINE BESSJN
!C       NB] ARGUMENT CAN BE NEGATIVE
!C
        X=DABS(X0)
        IF(X.LE.0.1)THEN
          M=4
        ELSE
          IF(X.LE.1.0)THEN
            M=8
          ELSE
            M=2*((INT(1.18*X)+13)/2)
          ENDIF
        ENDIF
        IF(M.GT.NMAX)GOTO 999
!C
        TOX=2.0/X
        ISUM=0
        sum1=0.
        BJP=0.
        BJ=1.
        jnx1(M)=1.0
        DO 10 N1=M,1,-1
        N=N1-1
        BJN=N1*TOX*BJ-BJP
        BJP=BJ
        BJ=BJN
        IF(DABS(BJ).GT.BIGNO)THEN
          BJ=BJ*BIGNI
          BJP=BJP*BIGNI
          sum1=sum1*BIGNI
          DO 20 I=N1,M
          jnx1(I)=jnx1(I)*BIGNI
20        CONTINUE
        ENDIF
        IF(N.NE.0)jnx1(N)=BJ
        IF(ISUM.NE.0)sum1=sum1+BJ
        ISUM=1-ISUM
10      CONTINUE
        sum1=(2.0*sum1)-BJ
        j0x1=BJ/sum1
        sign1=1.0
        DO 30 N=1,M
        sign1=-sign1
        jnx1(N)=jnx1(N)/sum1
        IF(X0.LT.0.0)jnx1(N)=jnx1(N)*sign1
        IF(N.LE.DABS(X).OR.jnx1(N).GT.TOL) then
            max11=N
        endif
30      CONTINUE
        RETURN
999     WRITE(6,9999)
        print *,'Error: JSET'
        return
        ! STOP
9999    FORMAT(//' *** OVERFLOW OF BESSEL FUNCTION ARRAY ***')
        END subroutine JSET

!
! added auxiliary routine by srio
!
        SUBROUTINE GetFromNml( period1,kx1,ky1,N,ENERGY, &
           CUR,NPHI,dalpha1,NE,NT,NP)

        !IMPLICIT REAL*8 (A-H,O-Z)
        implicit none

        double precision, intent(inout)    :: period1,kx1,ky1
        double precision, intent(inout)    :: ENERGY,CUR,dalpha1
        integer, intent(inout) :: N,NPHI

        integer :: NCOMP,ICOMP
        double precision :: RCURR,BPASS
        integer :: IANGLE,IAPERTURE,IEXTERNAL
        character(len=1024) :: FOUT,FIN,FTRAJ,FINT
        double precision :: EMIN,EMAX
        double precision :: THEMIN,THEMAX,PHIMIN,PHIMAX
        integer :: NE,NT,NP,NCHECK,IOPT,ITER,IPASS
        integer :: I_EDIV,IINT
        double precision  :: EDIVX,EDIVY

        integer :: i_device, n0
        double precision :: rlau, oldener, rk, rkx, rlen

        NAMELIST /PARAIN/ NCOMP,RCURR,ICOMP,BPASS,  &
           IANGLE,IAPERTURE,IEXTERNAL,  &
           FOUT,FIN,FTRAJ,EMIN,EMAX,  &
           THEMIN,THEMAX,PHIMIN,PHIMAX,  &
           NE,NT,NP,NCHECK,IOPT,ITER,IPASS,  &
           I_EDIV,EDIVX,EDIVY,FINT,IINT

        NAMELIST /EPATH1/ I_DEVICE, N0, RLAU, OLDENER, RK, RKX, RLEN
!

!C
!C Read in the parameters from namelist files
!C
        OPEN (21, FILE='uphot.nml', STATUS='OLD')
        READ (21, NML=PARAIN)
        write(6,NML=PARAIN)
        CLOSE (21)

        OPEN (21, FILE='epath.nml', STATUS='OLD')
        READ (21, NML=EPATH1)
        write(6,NML=EPATH1)
        CLOSE (21)

        period1 = RLAU
        kx1 = 0
        ky1 = rk
        n = ncomp
        energy = oldener
        cur = rcurr
        nphi = 0
        dalpha1 = 0.0D0

!C
!C Read in the (energy, theta, phi) array
!C
        END SUBROUTINE GetFromNml

end module shadow_pre_sync_urgent


       SUBROUTINE RES(T,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR,senpar)
       IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER(I-N)
       DIMENSION Y(*), YPRIME(*), DELTA(*),RPAR(*),IPAR(*),senpar(*)
*
          DELTA(1) = YPRIME(1) - Y(3)
          DELTA(2) = YPRIME(2) - Y(4)
          DELTA(3) = YPRIME(3) + Y(1)*Y(5)
          DELTA(4) = YPRIME(4) + Y(2)*Y(5) + 1.0D0
          DELTA(5) = cj*(Y(1)*Y(3) + Y(2)*Y(4))
*          delta(5) = y(3)*y(3) + y(4)*y(4) - y(5) - y(2)
*
       RETURN
       END


  subroutine barfit (fbObj, a, z, il, bfis, egs)

! ======================================================================
!
!***********************************************************************
!          S. G. Mashnik intoduced (25.10.1992) the following changes: *
!******************   z=zsierk, a=asierk, iz=z, ia=a   *****************
!                                                                      *
!   Removed unnecessary real*8 variables;                              *
!   Other changes made to fit into CEM95; A. J. Sierk, February, 1996. *
!   Made consistently real*8 for all f.p. variables;
!   Removed EQUIVALENCE statements;
!   Gives egs = egs(Lmax) for L >= Lmax.
!   Edited by A. J. Sierk, LANL T-16, October, 2003.
!   Edited by LMK, LANL XCP-3, July 2013 (included error protection).
!
!***********************************************************************
!
!    This subroutine returns the barrier height bfis, and the rotating
!    ground state energy, egs (in MeV) when called with real arguments
!    z, the atomic number, a, the atomic mass number, and (integer) il,
!    the angular momentum in units of h-bar, (Planck's constant divided
!    by 2*pi).
!
!         The fission barrier for il = 0 is calculated from a 7th order
!    fit in two variables to 638 calculated fission barriers for z
!    values from 20 to 110.  These 638 barriers are fit with an rms
!    deviation of 0.10 Mev by this 49-parameter function.
!    If BARFIT is called with (z,a) values outside the range of the
!    fit the barrier height is set to 0.0, and a message is
!    printed on unit 16.
!
!         For il values not equal to zero, the values of
!    l at which the barrier is  80%  and  20%  of the l=0 value are
!    respectively fit to 20-parameter functions of  z  and  a, over a
!    more restricted range of  a  values, than is the case for  l = 0.
!    The value of l where the barrier disappears, lmax, for 81 nuclei,
!    is fit to a 40-parameter function of z and a.
!         Once again, if a (z,a) pair is outside of the range of
!    validity of the fit, the barrier value is set to 0.0 and a message
!    is printed. These three values  (bfis(l=0), l-80, and l-20) and the
!    constraints of bfis = 0 and  d(bfis)/dl = 0 at l = lmax and
!    d(bfis)/dl = 0 at l = 0 lead to a fifth-order fit to bfis(l) for
!    l>= l-20.  The last constraint, and the values l-80 and l-20,
!    and bfis(l=0) lead to a third-order fit for the region l <= l-20.
!
!         The ground-state energies are calculated from a 175-parameter
!    fit in Z, A, and L to 329 ground-state energies for 36 different
!    Z  and  A  values.
!    (The range of Z and A is the same as for L-80, L-20, and L-max)
!
!         The calculated barriers from which the fits were
!    made were calculated in 1983-1985 by A. J. Sierk of Los Alamos
!    National Laboratory, Group T-9, using  Yukawa-plus-exponential
!    double folded nuclear energy, exact Couloub diffuseness corrections,
!    and diffuse-matter moments of inertia. The parameters of the model
!    are those derived by Moller and Nix in 1979:
!    r-0 = 1.16 fm, as = 21.13 Mev, kappa-s = 2.3  a = 0.68 fm.
!    The diffuseness of the matter and charge distributions used
!    corresponds to a surface diffuseness parameter (defined by Myers)
!    of 0.99 fm.  The fitted barriers for l = 0 are deviate from the
!    calculated ones by less than 0.1 MeV;  The output from this
!    subroutine is a little less accurate.  Worst errors may be as large
!    as 0.5 MeV; characteristic uncertainty is in the range of 0.1-0.2
!    MeV.  The values of egs are generally approximated to within
!    about 0.1-0.2 MeV;  the largest deviation is about 0.5 Mev,
!    near L-I for light nuclei.

!         The rms deviation of lmax from the 81 input values is ~0.1
!    h-bar.  The approximate value found by this code is nearly always
!    within 0.5 h-bar of the calculated one.
!
!    Below is a table of test values to check implementation
!    of the program:
!               z, a, il  fiss bar lmax    egs
!
!              28, 58, 0   33.14   45.8   0.00
!                    ,25   19.50         21.61
!                    ,40    2.88         50.12
!                    ,45.   0.07         58.18
!              65,153, 0   28.88   82.1   0.00
!                    ,50   16.16         19.07
!                    ,80    0.23         45.37
!                    ,82.   0.00         46.95
!              93,229, 0    3.76   68.1   0.00
!                    ,45    1.26          8.22
!                    ,68.   0.00         17.93
!
! ======================================================================
!
!    written by A. J. Sierk,  LANL  T-9
!    version 1.0   February, 1984
!    version 1.1   January, 1985:  improved coefficients in egs and lmax
!    version 1.2   September, 1985:  improved lmax, egs coefficients
!    version 1.21  June, 1986:   minor changes made
!    version 1.3   February, 1996: Moved elmax to subroutine, improved
!                  elmax coefficients.
!
!    Modified to calculate approximate egs for L > Lmax, A > 250, or
!       Z > 100;  AJS  02/14/05.
!    Edited by AJS, LANL T-2, December, 2011.
!    Edited by LMK, XCP-3, July 2013 (included error protection).
!
! ======================================================================
!
!      Copyright, 1996,  the Regents of the University of California.
!      This software was produced under a U. S. government contract
!      (w-7405-eng-36) by the Los Alamos National Laboratory, which is
!      operated by the University of California for the U. S. Department
!      of Energy.  The U. S. government is licensed to use, reproduce,
!      and distribute this software.  Permission is granted to the public
!      to copy and use this software without charge, provided that this
!      notice and any statement of authorship are reproduced on all
!      copies.  Neither the government nor the University makes any
!      warranty, expressed or implied, or assumes any liability
!      or responsibility for the use of this software.
!
! ======================================================================

    use, intrinsic :: iso_fortran_env, only: int32, real64
    use fissionBarrierParams, only: zro, one, two, thr, four

    implicit none
    class(FissionBarrier), intent(inout) :: fbObj
    real(real64),          intent(in   ) :: a
    real(real64),          intent(in   ) :: z
    integer(int32),        intent(in   ) :: il
    real(real64),          intent(  out) :: egs
    real(real64),          intent(  out) :: bfis

    integer(int32) :: i, iz, j, k, l, m
    real(real64)   :: a1, a2, aa, aj, ak, amax, amin, bfdum, el, el20, &
         & el80, ell, elmax, q, qa, qb, temp, x, y, z1, zz

    real(real64), dimension( 7) :: pa = zro, pz= zro
    real(real64), dimension(10) :: pl = zro

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

    real(real64), dimension(5,4) :: emncof
    data emncof  &
         /-9.01100d+2,-1.40818d+3, 2.77000d+3,-7.06695d+2, 8.89867d+2, &
         1.35355d+4,-2.03847d+4, 1.09384d+4,-4.86297d+3,-6.18603d+2, &
         -3.26367d+3, 1.62447d+3, 1.36856d+3, 1.31731d+3, 1.53372d+2, &
         7.48863d+3,-1.21581d+4, 5.50281d+3,-1.33630d+3, 5.05367d-2/

    real(real64), dimension(5,4) :: elmcof
    data elmcof  &
         /1.84542d+3,-5.64002d+3, 5.66730d+3,-3.15150d+3, 9.54160d+2, &
         -2.24577d+3, 8.56133d+3,-9.67348d+3, 5.81744d+3,-1.86997d+3, &
         2.79772d+3,-8.73073d+3, 9.19706d+3,-4.91900d+3, 1.37283d+3, &
         -3.01866d+1, 1.41161d+3,-2.85919d+3, 2.13016d+3,-6.49072d+2/

    real(real64), dimension(7,7) :: elzcof
    data elzcof  &
         /5.11819909d+5,-1.30303186d+6, 1.90119870d+6,-1.20628242d+6, &
         5.68208488d+5, 5.48346483d+4,-2.45883052d+4, &
         -1.13269453d+6, 2.97764590d+6,-4.54326326d+6, 3.00464870d+6, &
         -1.44989274d+6,-1.02026610d+5, 6.27959815d+4, &
         1.37543304d+6,-3.65808988d+6, 5.47798999d+6,-3.78109283d+6, &
         1.84131765d+6, 1.53669695d+4,-6.96817834d+4, &
         -8.56559835d+5, 2.48872266d+6,-4.07349128d+6, 3.12835899d+6, &
         -1.62394090d+6, 1.19797378d+5, 4.25737058d+4, &
         3.28723311d+5,-1.09892175d+6, 2.03997269d+6,-1.77185718d+6, &
         9.96051545d+5,-1.53305699d+5,-1.12982954d+4, &
         4.15850238d+4, 7.29653408d+4,-4.93776346d+5, 6.01254680d+5, &
         -4.01308292d+5, 9.65968391d+4,-3.49596027d+3, &
         -1.82751044d+5, 3.91386300d+5,-3.03639248d+5, 1.15782417d+5, &
         -4.24399280d+3,-6.11477247d+3, 3.66982647d+2/

    real(real64), dimension(5,7,5) :: egscof
    data ((egscof(i,j,1),i=1,5),j=1,7) &
         /-1.781665232d6,-2.849020290d6, 9.546305856d5, 2.453904278d5, 3.656148926d5, &
         4.358113622d6, 6.960182192d6,-2.381941132d6,-6.262569370d5, -9.026606463d5, &
         -4.804291019d6,-7.666333374d6, 2.699742775d6, 7.415602390d5, 1.006008724d6, &
         3.505397297d6, 5.586825123d6,-2.024820713d6,-5.818008462d5, -7.353683218d5, &
         -1.740990985d6,-2.759325148d6, 1.036253535d6, 3.035749715d5, 3.606919356d5, &
         5.492532874d5, 8.598827288d5,-3.399809581d5,-9.852362945d4, -1.108872347d5, &
         -9.229576432d4,-1.431344258d5, 5.896521547d4, 1.772385043d4, 1.845424227d4/

    data ((egscof(i,j,2),i=1,5),j=1,7) &
         /4.679351387d6, 7.707630513d6,-2.718115276d6,-9.845252314d5, -1.107173456d6, &
         -1.137635233d7,-1.870617878d7, 6.669154225d6, 2.413451470d6, 2.691480439d6, &
         1.237627138d7, 2.030222826d7,-7.334289876d6,-2.656357635d6,-2.912593917d6, &
         -8.854155353d6,-1.446966194d7, 5.295832834d6, 1.909275233d6, 2.048899787d6, &
         4.290642787d6, 6.951223648d6,-2.601557110d6,-9.129731614d5,-9.627344865d5, &
         -1.314924218d6,-2.095971932d6, 8.193066795d5, 2.716279969d5, 2.823297853d5, &
         2.131536582d5, 3.342907992d5,-1.365390745d5,-4.417841315d4, -4.427025540d4/

    data ((egscof(i,j,3),i=1,5),j=1,7) &
         /-3.600471364d6,-5.805932202d6, 1.773029253d6, 4.064280430d5, 7.419581557d5, &
         8.829126250d6, 1.422377198d7,-4.473342834d6,-1.073350611d6, -1.845960521d6, &
         -9.781712604d6,-1.575666314d7, 5.161226883d6, 1.341287330d6, 2.083994843d6, &
         7.182555931d6, 1.156915972d7,-3.941330542d6,-1.108259560d6, -1.543982755d6, &
         -3.579820035d6,-5.740079339d6, 2.041827680d6, 5.981648181d5, 7.629263278d5, &
         1.122573403d6, 1.777161418d6,-6.714631146d5,-1.952833263d5, -2.328129775d5, &
         -1.839672155d5,-2.871137706d5, 1.153532734d5, 3.423868607d4, 3.738902942d4/

    data ((egscof(i,j,4),i=1,5),j=1,7) &
         / 2.421750735d6, 4.107929841d6,-1.302310290d6,-5.267906237d5, -6.197966854d5, &
         -5.883394376d6,-9.964568970d6, 3.198405768d6, 1.293156541d6, 1.506909314d6, &
         6.387411818d6, 1.079547152d7,-3.517981421d6,-1.424705631d6,-1.629099740d6, &
         -4.550695232d6,-7.665548805d6, 2.530844204d6, 1.021187317d6, 1.141553709d6, &
         2.182540324d6, 3.646532772d6,-1.228378318d6,-4.813626449d5, -5.299974544d5, &
         -6.518758807d5,-1.070414288d6, 3.772592079d5, 1.372024952d5, 1.505359294d5, &
         9.952777968d4, 1.594230613d5,-6.029082719d4,-2.023689807d4,-2.176008230d4/

    data ((egscof(i,j,5),i=1,5),j=1,7) &
         /-4.902668827d5,-8.089034293d5, 1.282510910d5,-1.704435174d4, 8.876109934d4, &
         1.231673941d6, 2.035989814d6,-3.727491110d5, 4.071377327d3,-2.375344759d5, &
         -1.429330809d6,-2.376692769d6, 5.216954243d5, 7.268703575d4, 3.008350125d5, &
         1.114306796d6, 1.868800148d6,-4.718718351d5,-1.215904582d5, -2.510379590d5, &
         -5.873353309d5,-9.903614817d5, 2.742543392d5, 9.055579135d4, 1.364869036d5, &
         1.895325584d5, 3.184776808d5,-9.500485442d4,-3.406036086d4, -4.380685984d4, &
         -2.969272274d4,-4.916872669d4, 1.596305804d4, 5.741228836d3, 6.669912421d3/

! ======================================================================
!
!    The program starts here
!
! ======================================================================

    iz = nint(z)
    el = dble(il)
    if (iz < 19 .or. iz > 111) then
       bfis = fbObj%bf2 (a, z, il, egs)
       return
    endif
    if (iz > 102 .and. il > 0) then
       bfis = fbObj%bf2 (a, z, il, egs)
       return
    endif
    amin = 1.2d0*z + 0.01d0*z*z
    amax = 5.8d0*z - 0.024d0*z*z
    if (a < amin .or. a > amax) then
       bfis = fbObj%bf2 (a, z, il, egs)
       return
    endif
    aa = 2.5d-3*a
    zz = 1.d-2*z
    bfis = zro
    call lpoly2 (zz, pz, 7)
    call lpoly2 (aa, pa, 7)
    do i = 1,7
       do j = 1,7
          bfis = bfis + elzcof(j,i)*pz(j)*pa(i)
       end do
    end do
    egs = zro
    if (il < 1) return
    amin = 1.4d0*z + 0.009d0*z*z
    amax = 20.d0 + thr*z
    if (a < amin-5.d0 .or. a > amax+10.d0) then
       bfis = fbObj%bf2 (a, z, il, egs)
       return
    endif
    el80 = zro
    el20 = zro
    do i = 1,4
       do j = 1,5
          el80 = el80 + elmcof(j,i)*pz(j)*pa(i)
          el20 = el20 + emncof(j,i)*pz(j)*pa(i)
       end do
    end do
    call elmaxc (z, a, elmax)
    if (el > elmax) then
       bfis = zro
       z1 = one
    else
       temp = elmax
       if (temp < div0Lim .and. temp > -div0Lim) then
          temp = div0Lim
          write(fbObj%io%message,1000) "272-274"
          call fbObj%io%print(4, 3, fbObj%io%message)
       end if
       x = el20/temp
       y = el80/temp
       z1 = el/temp
       if (el <= el20) then
          temp = el20**2*el80**2*(el20 - el80)
          if (temp < div0Lim .and. temp > -div0Lim) then
             temp = div0Lim
             write(fbObj%io%message,1000) "281"
             call fbObj%io%print(4, 3, fbObj%io%message)
          end if
          q = 0.20d0/(temp)
          qa =  q*(four*el80**3 - el20**3)
          qb = -q*(four*el80**2 - el20**2)
          bfis = bfis*(one + qa*el**2 + qb*el**3)
       else
          aj = (-20.d0*x**5 + 25.d0*x**4 - four)*(y - one)**2*y*y
          ak = (-20.d0*y**5 + 25.d0*y**4 - one)*(x - one)**2*x*x
          temp = (y - x)*((one - x)*(one - y)*x*y)**2
          if (temp < div0Lim .and. temp > -div0Lim) then
             temp = div0Lim
             write(fbObj%io%message,1000) "293"
             call fbObj%io%print(4, 3, fbObj%io%message)
          end if
          q = 0.2d0/(temp)
          qa =  q*(aj*y - ak*x)
          qb = -q*(aj*(two*y + one) - ak*(two*x + one))
          a1 = four*z1**5 - 5.d0*z1**4 + one
          a2 = qa*(two*z1 + one)
          bfis = bfis*(a1 + (z1 - one)*(a2 + qb*z1)*z1*z1*(z1 - one))
       endif
       bfis = max(bfis,zro)
    endif

! Now calculate rotating ground-state energy
    ell = z1
    call lpoly2 (ell, pl, 9)
    egs = zro
    if (el <= elmax .and. a <= 250.d0 .and. z <= 100.d0) then
       do k = 1,5
!   Use powers of (A/250) from 0-4.
          do l = 1,7
!   Use powers of (Z/100) from 0-6.
             do m = 1,5
!   Use even powers of (l/lmax) from 0-8.
                egs = egs + egscof(m,l,k)*pz(l)*pa(k)*pl(2*m-1)
             end do
          end do
       end do
    else
       bfdum = fbObj%bf2 (a, z, il, egs)
    endif
    egs = max(egs, zro)

    return
! ======================================================================
1000 format("Divide by zero error prevented in 'barfit.f90', line(s) ", A)
! ======================================================================
  end subroutine barfit

  subroutine elmaxc (zn, an, elmax)
!  subroutine elmaxc (fbObj, zn, an, elmax)

! ======================================================================
!   This subroutine evaluates a 2-dimensional fitting function
!   to arrive at an approximation to Lmax(Z,A), the value of
!   angular momentum in units of h-bar at which the fission
!   saddle point and the fission barrier vanishes.  Lmax is the
!   maximum amount of angular momentum which the nucleus can
!   sustain without fissioning.
!
!   The 2-dimensional fit was made to 192 calculated values of
!   Lmax for values of Z from 10 to 110, with A values spanning
!   a range larger than any nuclei which might be formed in
!   a reaction.
!
!   The 192 calculated values of Lmax were calculated in the
!   three-quadratic-surface axially symmetric parametrization,
!   or in the triaxial Legendre Polynomial parametrization
!   using Yukawa-plus-exponential nuclear energy, diffuse
!   Coulomb energy, and diffuse-matter moments of inertia by
!   A. J. Sierk of Los Alamos National Laboratory, Group T-2.
!
!   This subroutine written February, 1994.
!   Updated constants and extendd Z and A range of fit, May, 1996.
!   Edited by A. J. Sierk, LANL T-16, October, 2003.
!   Edited by AJS, LANL T-2, December, 2011.
!
! ======================================================================

    use, intrinsic :: iso_fortran_env, only: int32, real64

    implicit none
!    class(FissionBarrier), intent(inout) :: fbObj   ! UNUSED!
    real(real64),          intent(in   ) :: zn
    real(real64),          intent(in   ) :: an
    real(real64),          intent(  out) :: elmax

    integer(int32) :: ia, ijb, iz
    real(real64)   :: xa, xz

    real(real64), dimension(npa) :: pla
    real(real64), dimension(npz) :: plz

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

    real(real64), parameter, dimension(40) :: b = &
         & [   -3.30787006d5,  8.34310803d5, -4.11955431d5,  9.82177374d5, &
         &      3.40653902d5,  8.39479538d5, -2.13869250d6,  1.11540268d6, &
         &     -2.52645986d6, -7.72016242d5, -1.00538896d6,  2.59234090d6, &
         &     -1.49269622d6,  3.06066515d6,  7.02514732d5,  7.97067135d5, &
         &     -2.08607738d6,  1.33444088d6, -2.52998737d6, -3.45973915d5, &
         &     -4.15169782d5,  1.10638461d6, -7.71715934d5,  1.45998634d6, &
         &      6.29116062d4,  1.07407080d5, -3.04281993d5,  2.18876998d5, &
         &     -5.37873263d5,  2.14561453d4,  1.64345870d3,  6.52424621d3, &
         &      3.41057615d3,  1.03029197d5, -1.17188782d4, -5.44933809d3, &
         &      1.23028722d4, -1.25511319d4, -5.30918539d3,  1.17305352d3   ]

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

    xz = zn/100.d0
    xa = an/320.d0
    elmax = 0.d0

    ! Obtain legendre polynomials
    call lpoly2 (xz, plz, npz)
    call lpoly2 (xa, pla, npa)

    ! Determine fission barrier saddle point
    do iz = 1,npz
       do ia = 1,npa
          ijb = ia + npa*(iz-1)
          elmax = elmax + b(ijb)*plz(iz)*pla(ia)
       end do
    end do

    return
! ======================================================================
  end subroutine elmaxc

  subroutine lpoly2 (x, ple, n)
!  subroutine lpoly2 (fbObj, x, ple, n)

! ======================================================================
!
!  Calculates the first n Legendre polynomials, those of order 0 to n-1.
!
!   Written by A. J. Sierk,  LANL T-2, February, 1994.
!   Modified by A. J. Sierk, LANL T-16, October, 2003.
!   Edited by AJS, LANL T-2, December, 2011.
!
! ======================================================================

    use, intrinsic :: iso_fortran_env, only: int32, real64
    use fissionBarrierParams, only: hlf, one, two, thr, fiv, seven

    implicit none
!    class(FissionBarrier), intent(inout)               :: fbObj   ! UNUSED!
    integer(int32),        intent(in   )               :: n
    real(real64),          intent(in   )               :: x
    real(real64),          intent(out  ), dimension(n) :: ple

    integer(int32) :: i
    real(real64)   :: dim1, dim2, d2im3

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

    ! The first polynomials (1 through 4) are:
    if ( n >= 1 ) ple(1) = one
    if ( n >= 2 ) ple(2) = x
    if ( n >= 3 ) ple(3) = hlf*(thr*x*x - one)
    if ( n >= 4 ) ple(4) = hlf*x*(fiv*x*x - thr)

    dim2 = thr
    dim1 = two*two
    d2im3 = seven

    ! Get higher order polynomials (>= 5)
    if (n >= 5) then
       do i = 5,n
          ple(i) = (d2im3*x*ple(i-1) - dim2*ple(i-2))/dim1
          dim2 = dim1
          dim1 = dble(i)
          d2im3 = two + d2im3
       end do
    endif

    return
! ======================================================================
  end subroutine lpoly2

  subroutine bsfit (fbObj, zn, an, il, bs)

! ======================================================================
!
!   This subroutine evaluates a 3-dimensional fitting function
!   to arrive at an approximation to Bs(Z,A,L), the value of
!   the surface area of the macroscopic saddle-point shape in units
!   of the area of the spherical nucleus.
!
!   The 200-parameter 3-dimensional fit was made to 1053 calculated
!   values of Bs for values of Z from 15 to 100, with A values spanning
!   a range larger than any nuclei which might be formed in
!   a reaction, and for L from 0 to Lmax.
!
!   The 1053 calculated values of Bs were calculated in the
!   Legendre Polynomial axially symmetric parametrization,
!   or in the triaxial Legendre Polynomial parametrization
!   using Yukawa-plus-exponential nuclear energy, diffuse
!   Coulomb energy, and diffuse-matter moments of inertia by
!   A. J. Sierk of Los Alamos National Laboratory, Group T-2,
!   in May, 1996.
!
!   ELMAXC subroutine written February, 1994.
!   BSFIT modified from ELMAXC, May, 1996.
!   Edited by AJS, LANL T-2, December, 2011.
!
! ======================================================================

    use, intrinsic :: iso_fortran_env, only: int32, real64
    use fissionBarrierParams, only: zro

    implicit none
    class(FissionBarrier), intent(inout) :: fbObj
    real(real64),          intent(in   ) :: zn
    real(real64),          intent(in   ) :: an
    integer(int32),        intent(in   ) :: il
    real(real64),          intent(  out) :: bs

    integer(int32) :: ia, ijb, ill, iz, npl2
    real(real64)   :: el, elmax, temp, xa, xl, xz

    real(real64), dimension( npa)    :: pla = zro
    real(real64), dimension( npz)    :: plz = zro
    real(real64), dimension(9_int32) :: pll = zro

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

    real(real64), parameter, dimension(270) :: b = &
         & [  -17605.486d0,  7149.518d0, 23883.053d0, 21651.272d0,  -348.402d0, &
         &     67617.841d0,-43739.724d0,-72255.975d0,-79130.794d0,-44677.571d0, &
         &    -38284.438d0,  1629.405d0, 49928.158d0, 41804.076d0, -4744.661d0, &
         &      2124.997d0,-30258.577d0,-45416.684d0,-40347.682d0,-20718.220d0, &
         &     -7009.141d0,-12274.997d0,  5703.797d0,  4375.711d0, -2519.378d0, &
         &     44633.464d0,-19664.988d0,-59871.761d0,-55426.914d0,  -834.542d0, &
         &   -168222.448d0,111291.480d0,179939.092d0,198092.569d0,111347.893d0, &
         &     97361.913d0,-9404.674d0,-15757.922d0,-108003.071d0,  7218.634d0, &
         &    -79483.915d0, 77325.943d0,113433.935d0,100793.473d0, 51134.715d0, &
         &     17974.287d0, 28084.202d0,-15187.024d0,-12244.758d0,  4662.638d0, &
         &    -52775.944d0, 26372.246d0, 69061.418d0, 66412.802d0,  4456.150d0, &
         &    191743.968d0,-131672.398d0,-204896.966d0,-227867.388d0, &
         &   -126609.907d0,-115704.145d0,  22053.324d0, 146315.778d0, &
         &    131364.763d0,   1176.787d0,  89552.374d0, -92216.043d0, &
         &   -129901.381d0,-115369.145d0, -56853.433d0, -21565.916d0, &
         &    -26595.626d0, 19490.177d0, 16758.541d0, -2102.079d0, 43089.492d0, &
         &    -24205.277d0, -54145.651d0, -54916.885d0,  -6982.880d0, &
         &   -148893.417d0,105958.013d0,157835.761d0,178691.634d0, 97246.541d0, &
         &     94988.919d0, -28100.912d0,-115999.016d0,-110379.031d0, & ! Items 1-89
         &    -10165.655d0, -68277.650d0, & ! Items 90-91
         &     75226.302d0,100957.904d0, 89635.423d0, 41887.718d0, 17720.511d0, &
         &     14837.634d0,-17476.245d0,-15762.519d0, -1297.194d0,-25673.002d0, &
         &     15584.030d0, 30291.575d0, 33008.500d0,  6161.347d0, 83671.721d0, &
         &    -60540.161d0,-86493.251d0,-101211.404d0,-53525.729d0, &
         &    -56872.290d0, 21837.845d0, 65632.326d0, 67209.922d0, 11367.245d0, &
         &     37417.011d0,-43832.496d0,-56023.110d0,-49995.410d0,-21521.767d0, &
         &    -10406.752d0, -4483.654d0, 11314.537d0, 10435.311d0,  2206.541d0, &
         &     11115.697d0, -6672.659d0,-11696.751d0,-14183.580d0, -3586.280d0, &
         &    -33914.223d0, 23453.203d0, 32630.486d0, 40847.174d0, 21223.389d0, &
         &     24704.794d0,-10226.568d0,-25497.313d0,-29082.833d0, -7190.865d0, &
         &    -14734.982d0, 17457.735d0, 21457.946d0, 19706.266d0,  7745.219d0, &
         &      4283.242d0,   214.103d0, -5058.390d0, -4715.987d0, -1303.557d0, &
         &     -3196.271d0,  1579.967d0,  2718.777d0,  3997.275d0,  1361.541d0, &
         &      9152.527d0, -5182.345d0, -7412.465d0,-10822.583d0, -5804.143d0, &
         &     -7177.709d0,  2317.015d0,  5874.736d0,  8208.479d0,  2858.079d0, &
         &      3919.329d0, -4068.562d0, -4982.296d0, -5065.564d0, -1948.636d0, &
         &     -1147.488d0,   265.063d0,  1372.992d0,  1333.320d0,   416.369d0, &
         &       442.331d0,  -219.051d0,  -337.663d0,  -575.255d0,  -232.634d0, & ! Items 92-180
         &     -1217.351d0,   590.169d0,   854.438d0,  1468.791d0,   811.481d0, &
         &      1031.157d0,  -227.306d0,  -651.183d0, -1174.558d0,  -528.960d0, &
         &      -536.534d0,   413.429d0,   533.977d0,   663.064d0,   278.203d0, &
         &       154.548d0,   -54.623d0,  -169.817d0,  -183.006d0,   -63.999d0, &
         &         0.0d0,       0.0d0,       0.0d0,       0.0d0,       0.0d0,   &
         &         0.0d0,       0.0d0,       0.0d0,       0.0d0,       0.0d0,   &
         &         0.0d0,       0.0d0,       0.0d0,       0.0d0,       0.0d0,   &
         &         0.0d0,       0.0d0,       0.0d0,       0.0d0,       0.0d0,   &
         &         0.0d0,       0.0d0,       0.0d0,       0.0d0,       0.0d0,   &
         &         0.0d0,       0.0d0,       0.0d0,       0.0d0,       0.0d0,   &
         &         0.0d0,       0.0d0,       0.0d0,       0.0d0,       0.0d0,   &
         &         0.0d0,       0.0d0,       0.0d0,       0.0d0,       0.0d0,   &
         &         0.0d0,       0.0d0,       0.0d0,       0.0d0,       0.0d0,   &
         &         0.0d0,       0.0d0,       0.0d0,       0.0d0,       0.0d0,   &
         &         0.0d0,       0.0d0,       0.0d0,       0.0d0,       0.0d0,   &
         &         0.0d0,       0.0d0,       0.0d0,       0.0d0,       0.0d0,   &
         &         0.0d0,       0.0d0,       0.0d0,       0.0d0,       0.0d0,   &
         &         0.0d0,       0.0d0,       0.0d0,       0.0d0,       0.0d0   ] ! Items 181-270

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

    npl2 = 2*npl - 1
    xz = zn/100.d0
    xa = an/320.d0
    el = dble(il)
    call elmaxc (zn, an, elmax)
    temp = elmax
    if (temp < div0Lim .and. temp > -div0Lim) then
       temp = div0Lim
       write(fbObj%io%message,1000) "569"
       call fbObj%io%print(4, 3, fbObj%io%message)
    end if
    xl = el/temp
    call lpoly2 (xz, plz, npz)
    call lpoly2 (xa, pla, npa)
    call lpoly2 (xl, pll, npl2)
    bs = zro
    do iz = 1,npz
       do ia = 1,npa
          do ill = 1,npl
             ijb = ill + npl*npa*(iz-1) + npl*(ia-1)
             bs = bs + b(ijb)*plz(iz)*pla(ia)*pll(2*ill-1)
          end do
       end do
    end do

    return
! ======================================================================
1000 format("Divide by zero error prevented in 'barfit.f90', line(s) ", A)
! ======================================================================
  end subroutine bsfit

  function bf2 (fbObj, a, z, ln, egs0)

! ======================================================================
!
!   Function to give fission barrier in Mev, given A, Z, L, and
!   excitation energy at the saddle point, e. bf2 is for use in
!   BARFIT when the a Z, A, L values lie outside the range of the fit.
!   It gives an approximate value using the Krappe-Nix-Sierk model.
!   Results are fairly crude, but should not be needed too often,
!   except perhaps for Z < 19 and Z > 12 (just above Fermi breakup).
!
!   CEM95 written by S. G. Mashnik
!   Edited by A. J. Sierk,  LANL  T-2  February, 1996.
!   bf2 created from bf by AJS, December, 1997
!   Modified by AJS, March, 1999.
!   "Last" change: 12-AUG-2003 by NVMokhov
!   Modified by A. J. Sierk, LANL T-16, October, 2003.
!   Modified by AJS, February, 2005.
!   Edited by AJS, LANL T-2, December, 2011.
!
! ======================================================================

    use, intrinsic :: iso_fortran_env, only: int32, real64
    use fissionBarrierParams, only: zro, hlf, one, thr, emnucb, ato3rd

    implicit none
    class(FissionBarrier), intent(inout) :: fbObj
    real(real64),          intent(in   ) :: a
    real(real64),          intent(in   ) :: z
    integer(int32),        intent(in   ) :: ln
    real(real64),          intent(  out) :: egs0
    real(real64)                         :: bf2

    integer(int32) :: in, iz
    real(real64)   :: a2, a3, a3rt, a3rt2, acor, athrd, bf, bf0, bx, &
         & coulmb, daz, dbfi, emcorr, emscorr, emx, ergs0, ersad, fjrb, &
         & fjsad, gamma, sufnuc, sym, temp, um2, un, w, x, zsq

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

    un = a - z
    zsq = z*z
    temp = a
    if (temp < div0Lim .and. temp > -div0Lim) then
       temp = div0Lim
       write(fbObj%io%message,1000) "642"
       call fbObj%io%print(4, 3, fbObj%io%message)
    end if
    sym = ((un - z)/temp)**2
    egs0 = 1.d-6
    iz = nint(z)
    in = nint(un)

    gamma = thr
    a2 = 21.7d0
    a3 = 0.7322d0
    athrd = ato3rd(nint(a))
    a3rt = athrd
    a3rt2 = a3rt**2
    acor = one - gamma*sym
    sufnuc = a2*acor*a3rt2
    coulmb = a3*zsq/a3rt
    temp = sufnuc
    if (temp < div0Lim .and. temp > -div0Lim) then
       temp = div0Lim
       write(fbObj%io%message,1000) "666"
       call fbObj%io%print(4, 3, fbObj%io%message)
    end if
    x = hlf*coulmb/temp
    emx = fbObj%fbMolnix%defineEnergy (iz, in, 2)
    temp = emnucb*a
    if (temp < div0Lim .and. temp > -div0Lim) then
       temp = div0Lim
       write(fbObj%io%message,1000) "673"
       call fbObj%io%print(4, 3, fbObj%io%message)
    end if
    emcorr = one + 0.001d0*emx/(temp)
    um2 = dble(ln)**2
!  Finite-range approximation to rigid sphere moment of inertia:
    fjrb = (fbObj%options%r0m*fbObj%options%r0m*athrd**2 + 10.d0*amm**2)*a
    temp = fjrb
    if (temp < div0Lim .and. temp > -div0Lim) then
       temp = div0Lim
       write(fbObj%io%message,1000) "682"
       call fbObj%io%print(4, 3, fbObj%io%message)
    end if
    ergs0 = 52.252429d0*um2/temp
    temp = emcorr
    if (temp < div0Lim .and. temp > -div0Lim) then
       temp = div0Lim
       write(fbObj%io%message,1000) "688"
       call fbObj%io%print(4, 3, fbObj%io%message)
    end if
    ergs0 = ergs0/temp
    if (x >= one) then
       bf2 = zro
    else
       bx = fbObj%subev (x, xx2, yy2, 51)
       bf0 = sufnuc*bx
       bf0 = max(bf0, zro)
       daz = fbObj%fbMolnix%shellEnergy(a, z)
       bf = bf0 - daz
!  Approximate rotational lowering of barrier:
!  w = Strutinsky approximation to LDM moment of inertia of saddle:
       w = fbObj%subev (x, xx1, ws, 51)
!  Finite-range approximation to rigid saddle moment of inertia:
!  (Diffuseness correction is independent of shape!!)
       fjsad = (w*fbObj%options%r0m*fbObj%options%r0m*athrd**2 + 10.d0*amm**2)*a
       temp = emnucb*a
       if (temp < div0Lim .and. temp > -div0Lim) then
          temp = div0Lim
          write(fbObj%io%message,1000) "708"
          call fbObj%io%print(4, 3, fbObj%io%message)
       end if
       emscorr = one + 0.001d0*(emx + bf)/(temp)
       temp = fjsad
       if (temp < div0Lim .and. temp > -div0Lim) then
          temp = div0Lim
          write(fbObj%io%message,1000) "714"
          call fbObj%io%print(4, 3, fbObj%io%message)
       end if
       ersad = 52.252429d0*um2/temp
       temp = emscorr
       if (temp < div0Lim .and. temp > -div0Lim) then
          temp = div0Lim
          write(fbObj%io%message,1000) "720"
          call fbObj%io%print(4, 3, fbObj%io%message)
       end if
       ersad = ersad/temp
       dbfi = ersad - ergs0
       bf = bf + dbfi
       bf2 = max(bf, zro)
    endif
    egs0 = ergs0

    return
! ======================================================================
1000 format("Divide by zero error prevented in 'barfit.f90', line(s) ", A)
! ======================================================================
  end function bf2


! -*- F90 -*-

double precision function alphasPDF(Q)
  implicit none
  integer nset
  double precision Q,a
  call getnset(nset)
  call evolveAs(nset,Q,a)
  alphasPDF=a
  return
end function alphasPDF

double precision function alphasPDFM(nset,Q)
  implicit none
  integer nset
  double precision Q,a
  call evolveAs(nset,Q,a)
  alphasPDFM=a
  return
end function alphasPDFM

subroutine GetQmass(nnf,mass)
  implicit none
  double precision mass
  integer nnf,order,nset
  nset = 1
  call GetQmassM(nset,nnf,mass)
  return
  entry GetOrderAs(order)
  nset = 1
  call GetOrderAsM(nset,order)
  return
end subroutine GetQmass

subroutine evolveAs(nset,Q,alphas)
  implicit none
  include 'parmsetup.inc'
  integer iset,imem
  common/SET/iset,imem
  integer nset
  character*16 s1,s2,s3
  double precision Q,alphas,alfas0,scale0
  double precision Q0(nmxset)
  double precision AlfasQ(nmxset)
  double precision b0,b1,b2,L,As,mass
  double precision CtLhALPI,CtLhAlphaNew,CtLhALPInew,CtLhalgluino
  parameter (b0=1.2202,b1=0.4897,b2=0.1913)
  integer n!,k
  integer order
  integer EvlOrd(nmxset)
  integer parm(nmxset)
  integer Etype(nmxset)
  integer Method(nmxset)
  integer nnf,naf
  double precision cmass(nmxset),bmass(nmxset),tmass(nmxset)
  common/masses_LHA/cmass,bmass,tmass
  save EvlOrd,parm,Etype,alfasQ,Q0,Method

  call setnset(nset)

  if (method(nset).eq.0) then
     if ((Etype(nset).eq.1).or.(Etype(nset).eq.2)) then
        L=log(Q/Q0(nset))
        As=alfasQ(nset)
        if (Etype(nset).eq.2) call GetParmPDF(nset,parm(nset),As)
        if (EvlOrd(nset).eq.0) L=b0*L
        if (EvlOrd(nset).eq.1) L=(b0+As*b1)*L
        if (EvlOrd(nset).eq.2) L=(b0+As*b1+As**2*b2)*L -0.5*As**2*b0*b1/2d0*L**2
        alphas=As/(1.0+As*L)
     endif
  endif
  if (method(nset).eq.1) then
     call alfasevolve(nset,alphas,Q)
  elseif (method(nset).eq.2) then
     call alphamrs(5,alphas,Q)
  elseif (method(nset).eq.3) then
     if(Etype(nset).eq.1) alphas = 3.1415926535898d0*CtLhALPI(Q)
     if(Etype(nset).eq.2) alphas = 3.1415926535898d0*CtLhALPInew(Q)
  elseif (method(nset).eq.4) then
     alphas = CtLhAlphaNew(Q)
  elseif (method(nset).eq.5) then
     call alphamrs(3,alphas,Q)
  elseif (method(nset).eq.6) then
     call alphamrs(4,alphas,Q)
  elseif (method(nset).eq.7) then
     call alphacteq5f34(3,alphas,Q)
  elseif (method(nset).eq.8) then
     call alphacteq5f34(4,alphas,Q)
  elseif (method(nset).eq.9) then
     alphas = CtLhalgluino(Q)
  endif
  return

  entry GetQmassM(nset,nnf,mass)
  n=abs(nnf)
  mass=0d0
  if (n.eq.4) mass=cmass(nset)
  if (n.eq.5) mass=bmass(nset)
  if (n.eq.6) mass=tmass(nset)
  return

  entry GetNactive(naf,q)
  ! compute nnfn = number of active flavors at scale qin.
  n = 3
  if(q .ge. cmass(nset)) n = 4
  if(q .ge. bmass(nset)) n = n + 1
  if(q .ge. tmass(nset)) n = n + 1
  naf = n
  return

  entry GetAlfas(nset,alfas0,scale0)
  scale0=Q0(nset)
  alfas0=alfasQ(nset)
  if (Etype(nset).eq.2) call GetParmPDF(nset,parm(nset),alfas0)
  return

  entry GetOrderAsM(nset,order)
  order=EvlOrd(nset)
  return

  entry InitAlphasPDF(nset)
  Etype(nset)=-1
  EvlOrd(nset)=-1
  read(1,*) s1,s2,s3
  if (index(s2,'lo').eq.1) EvlOrd(nset)=0
  if (index(s2,'nlo').eq.1) EvlOrd(nset)=1
  if (index(s2,'nnlo').eq.1) EvlOrd(nset)=2
  if (EvlOrd(nset).lt.0) then
     write(*,*) 'File description error:'
     write(*,*) 'Unknown alpha_s evolution order ',s2
     stop
  endif
  if (index(s1,'Fixed').eq.1) then
     Etype(nset)=1
     parm(nset)=-1
     read(1,*) alfasQ(nset),Q0(nset),cmass(nset),bmass(nset),tmass(nset)
  endif
  if (index(s1,'Variable').eq.1) then
     Etype(nset)=2
     alfasQ(nset)=0d0
     read(1,*) parm(nset),Q0(nset),cmass(nset),bmass(nset),tmass(nset)
  endif
  if (Etype(nset).lt.0) then
     write(*,*) 'File description error:'
     write(*,*) 'Unknown alpha_s evolution method ',s1
     stop
  endif
  Method(nset)=-1
  if (index(s3,'Internal').eq.1) Method(nset)=0
  if (index(s3,'EvolCode').eq.1) Method(nset)=1
  if (index(s3,'MRSTalfa').eq.1) Method(nset)=2
  if (index(s3,'CTEQalfa').eq.1) Method(nset)=3
  if (index(s3,'CTEQABalfa').eq.1) Method(nset)=4
  if (index(s3,'MRST3alfa').eq.1) Method(nset)=5
  if (index(s3,'MRST4alfa').eq.1) Method(nset)=6
  if (index(s3,'CTEQ5F3alfa').eq.1) Method(nset)=7
  if (index(s3,'CTEQ5F4alfa').eq.1) Method(nset)=8
  if (index(s3,'CTEQ6LGalfa').eq.1) Method(nset)=9
  if (Method(nset).lt.0) then
     write(*,*) 'File description error:'
     write(*,*) 'Unknown alpha_s method ',s3
     stop
  endif
  return
end subroutine evolveAs

subroutine alphamrs(nflav,alpha,Q)
  IMPLICIT double precision (a-h,o-z)
  include 'parmsetup.inc'
  common/SET/iset,imem
  common/masses_LHA/cmass(nmxset),bmass(nmxset),tmass(nmxset)
  dimension parms(31)
  DATA PI/3.14159/
  DATA TOL/.0005/
  data memold/-1/
  integer nset
  save alambda,memold
  call getnset(nset)

  ! Find alambda corresponding to alphas given in first parameter
  call getnmem(nset,imem)
     call listPDF(nset,imem,parms)
     alphas = parms(1)
     memold=imem
     qz2=8315.
     qz = dsqrt(qz2)
     alambda = 0.3000
     astep = 0.010
     tol2 = 0.0000001
     idir = +1
10   continue
     alambda = alambda + idir*astep
     call mrslambda(nflav,alpha,qz,alambda)

     if(idir*(alphas-alpha).gt.0.0) then
        go to 20
     else
        astep = 0.5*astep
        idir = -1*idir
        go to 20
     endif
20   continue
     if(abs(alpha-alphas).gt.tol2) go to 10
  ! alambda found  -- save it !!!!
  ! next call mrslambda to get alphas at q with the correct alambda
  call mrslambda(nflav,alpha,q,alambda)
  RETURN
END subroutine alphamrs

subroutine rgras(alpha,Q2)
  IMPLICIT double precision (a-h,o-z)
  !double precision mc,mb,mt
  include 'parmsetup.inc'
  character*16 name(nmxset)
  integer nmem(nmxset),ndef(nmxset),mem
  common/NAME/name,nmem,ndef,mem
  q=dsqrt(q2)
  call getnset(nset)
  nflav=5
  if(name(nset).eq.'QCDNUM_MRST3') nflav=3
  if(name(nset).eq.'QCDNUM_MRST4') nflav=4
  call alphamrs(nflav,alpha,Q)
  return
end subroutine rgras

! new vewrsion of mrslambda 13/5/2004 - includes lo, nlo, and nnlo with flags
subroutine mrslambda(nflav,alpha,Q,alambda)
  IMPLICIT DOUBLE PRECISION(A-H,O-Z)
  DATA PI/3.14159/
  DATA TOL/.0005/
  !  The value of Lambda required corresponds to nflav=4
  !  iord=0 gives leading order, iord=1 gives NLO, iord=2 gives NNLO
  qsdt=8.18    !!  This is the value of 4m_c^2
  qsct=74.0    !!  This is the value of 4m_b^2
  al2=alambda*alambda
  q2=q*q
  t=dlog(q2/al2)

  ! CHECK: explicitly initialising ALFQC{3,4,5} (by AB)
  ALFQC3 = 0
  ALFQC4 = 0
  ALFQC5 = 0

  call getnset(nset)
  call GetOrderAsM(nset,iord)
  ITH=0
  TT=T
  qsdtt=qsdt/4.
  qsctt=qsct/4.
  AL=ALAMBDA
  AL2=AL*AL
  FLAV=4.
  if(nflav.eq.3) flav=3.
  QS=AL2*dEXP(T)

  if(qs.lt.0.5d0) then   !!  running stops below 0.5
     qs=0.5d0
     t=dlog(qs/al2)
     tt=t
  endif

  IF(QS.gt.QSCTT.and.nflav.gt.4) GOTO 12
  IF(QS.lt.QSDTT.and.nflav.gt.3) GOTO 312
11 CONTINUE
  B0=11-2.*FLAV/3.
  X1=4.*PI/B0
  IF(IORD.eq.0) then
     ALPHA=X1/T
  ELSE
     if(iord.gt.1) then
        alpha=qwikalf(t,iord,flav)
        go to 51
     endif
     B1=102.-38.*FLAV/3.
     X2=B1/B0**2
     AS2=X1/T*(1.-X2*dLOG(T)/T)
5    AS=AS2
     F=-T+X1/AS-X2*dLOG(X1/AS+X2)
     FP=-X1/AS**2*(1.-X2/(X1/AS+X2))
     AS2=AS-F/FP
     DEL=ABS(F/FP/AS)
     IF((DEL-TOL).GT.0.) go to 5
     ALPHA=AS2
51   continue
  ENDIF
  IF(ITH.EQ.0) RETURN
  GO TO (13,14,15) ITH
  ! GO TO 5
12 ITH=1
  T=dLOG(QSCTT/AL2)
  GO TO 11
13 ALFQC4=ALPHA
  FLAV=5.
  ITH=2

  GO TO 11
14 ALFQC5=ALPHA
  ITH=3
  T=TT
  GO TO 11
15 ALFQS5=ALPHA
  ALFINV=1./ALFQS5+1./ALFQC4-1./ALFQC5
  ALPHA=1./ALFINV
  RETURN

311 CONTINUE
  B0=11-2.*FLAV/3.
  X1=4.*PI/B0
  IF(IORD.eq.0) then
     ALPHA=X1/T

  ELSE
     if(iord.gt.1) then
        alpha=qwikalf(t,iord,flav)
        go to 351
     endif
     B1=102.-38.*FLAV/3.
     X2=B1/B0**2
     AS2=X1/T*(1.-X2*dLOG(T)/T)
35   AS=AS2
     F=-T+X1/AS-X2*dLOG(X1/AS+X2)
     FP=-X1/AS**2*(1.-X2/(X1/AS+X2))
     AS2=AS-F/FP
     DEL=ABS(F/FP/AS)
     IF((DEL-TOL).GT.0.) go to 35
     ALPHA=AS2

351  continue
  endif
  IF(ITH.EQ.0) RETURN
  GO TO (313,314,315) ITH
312 ITH=1
  T=dLOG(QSDTT/AL2)
  GO TO 311
313 ALFQC4=ALPHA
  FLAV=3.
  ITH=2
  GO TO 311
314 ALFQC3=ALPHA
  ITH=3
  T=TT
  GO TO 311
315 ALFQS3=ALPHA
  ALFINV=1./ALFQS3+1./ALFQC4-1./ALFQC3
  ALPHA=1./ALFINV
  RETURN
END subroutine mrslambda

double precision function qwikalf(t,iord,flav)
  implicit double precision(a-h,o-z)
  dimension z3(6),z4(6),z5(6),zz3(6),zz4(6),zz5(6)
  data z3/ -.161667E+01,0.954244E+01,0.768623E+01,0.101523E+00,-.360127E-02,0.457867E-04/
  data z4/ -.172239E+01,0.831185E+01,0.721463E+01,0.835531E-01,-.285436E-02,0.349129E-04/
  data z5/ -.872190E+00,0.572816E+01,0.716119E+01,0.195884E-01,-.300199E-03,0.151741E-05/
  data zz3/-.155611E+02,0.168406E+02,0.603014E+01,0.257682E+00,-.970217E-02,0.127628E-03/
  data zz4/-.106762E+02,0.118497E+02,0.664964E+01,0.112996E+00,-.317551E-02,0.302434E-04/
  data zz5/-.531860E+01,0.708503E+01,0.698352E+01,0.274170E-01,-.426894E-03,0.217591E-05/

  data pi/3.14159/
  nfm2=flav-2.
  x=dsqrt(t)
  x2=x*x
  x3=x*x2
  x4=x*x3
  x5=x*x4
  go to (1,2) iord
1 go to (3,4,5) nfm2
3 y=z3(1)+z3(2)*x+z3(3)*x2+z3(4)*x3+z3(5)*x4+z3(6)*x5
  go to 10
4 y=z4(1)+z4(2)*x+z4(3)*x2+z4(4)*x3+z4(5)*x4+z4(6)*x5
  go to 10
5 y=z5(1)+z5(2)*x+z5(3)*x2+z5(4)*x3+z5(5)*x4+z5(6)*x5
  go to 10
2 go to (6,7,8) nfm2
6 y=zz3(1)+zz3(2)*x+zz3(3)*x2+zz3(4)*x3+zz3(5)*x4+zz3(6)*x5
  go to 10
7 y=zz4(1)+zz4(2)*x+zz4(3)*x2+zz4(4)*x3+zz4(5)*x4+zz4(6)*x5
  go to 10
8 y=zz5(1)+zz5(2)*x+zz5(3)*x2+zz5(4)*x3+zz5(5)*x4+zz5(6)*x5
  go to 10
10 qwikalf=4.*pi/y
  return
end function qwikalf

!=====================================================================
! alphas routine from PDFLIB
! D OUBLE PRECISION FUNCTION ALPHAS2(SCALE,qcdl5)
subroutine aspdflib(alphas2,SCALE,iord,qcdl5)
  implicit double precision (a-h,o-z)
  double precision NF
  DATA XMC/1.43D0/,XMB/4.30D0/,XMT/100.D0/
  DATA ZEROD/0.D0/,PONED/0.001D0/,ONED/1.D0/,TWOD/2.D0/

  LO = 1
  if(iord.ne.0) LO = 2

  TMAS = 180.0d0

  ALPHAS2 = ZEROD
  PI=4.0D0*ATAN(ONED)
  B6  = (33.D0-2.D0*6.D0)/PI/12.D0
  BP6 = (153.D0 - 19.D0*6.D0) / PI / TWOD / (33.D0 - 2.D0*6.D0)
  B5  = (33.D0-2.D0*5.D0)/PI/12.D0
  BP5 = (153.D0 - 19.D0*5.D0) / PI / TWOD / (33.D0 - 2.D0*5.D0)
  B4  = (33.D0-2.D0*4.D0)/PI/12.D0
  BP4 = (153.D0 - 19.D0*4.D0) / PI / TWOD / (33.D0 - 2.D0*4.D0)
  B3  = (33.D0-2.D0*3.D0)/PI/12.D0
  BP3 = (153.D0 - 19.D0*3.D0) / PI / TWOD / (33.D0 - 2.D0*3.D0)
  XLC = TWOD * LOG( XMC/QCDL5)
  XLB = TWOD * LOG( XMB/QCDL5)
  XLT = TWOD * LOG( XMT/QCDL5 * TMAS/XMT)
  XLLC = LOG( XLC)
  XLLB = LOG( XLB)
  XLLT = LOG( XLT)
  C65  =  ONED/( ONED/(B5 * XLT) - XLLT*BP5/(B5 * XLT)**2 ) - &
       ONED/( ONED/(B6 * XLT) - XLLT*BP6/(B6 * XLT)**2 )
  C45  =  ONED/( ONED/(B5 * XLB) - XLLB*BP5/(B5 * XLB)**2 ) - &
       ONED/( ONED/(B4 * XLB) - XLLB*BP4/(B4 * XLB)**2 )
  C35  =  ONED/( ONED/(B4 * XLC) - XLLC*BP4/(B4 * XLC)**2 ) - &
       ONED/( ONED/(B3 * XLC) - XLLC*BP3/(B3 * XLC)**2 ) + C45

  Q = SCALE
  XLQ = TWOD *  LOG( Q/QCDL5 )
  XLLQ =  LOG( XLQ )

  ! IF  ( NF .LT. ZEROD) THEN
  IF ( Q .GT. XMT * TMAS/XMT) THEN
     NF = 6.D0
  ELSEIF  ( Q .GT. XMB ) THEN
     NF = 5.D0
  ELSEIF  ( Q .GT. XMC ) THEN
     NF = 4.D0
  ELSE
     NF = 3.D0
  ENDIF
  IF(NF .GT. 6.D0) NF = 6.D0
  IF      ( NF .EQ. 6.D0 ) THEN
     ALF = ONED/(ONED/(ONED/(B6*XLQ)- BP6/(B6*XLQ)**2*XLLQ) + C65)
     IF (LO.EQ.1) ALF = ONED/B6/XLQ
  ELSEIF  ( NF .EQ. 5.D0 ) THEN
     ALF = ONED/(B5 * XLQ) -  BP5/(B5 * XLQ)**2 * XLLQ
     IF (LO.EQ.1) ALF = ONED/B5/XLQ
  ELSEIF  ( NF .EQ. 4.D0 ) THEN
     ALF = ONED/(ONED/(ONED/(B4*XLQ)- BP4/(B4*XLQ)**2*XLLQ) + C45)
     IF (LO.EQ.1) ALF = ONED/B4/XLQ
  ELSEIF  ( NF .EQ. 3.D0 ) THEN
     ALF = ONED/(ONED/(ONED/(B3*XLQ)- BP3/(B3*XLQ)**2*XLLQ) + C35)
     IF (LO.EQ.1) ALF = ONED/B3/XLQ
  ELSE
     WRITE(*,*) 'Error in Alphas2'
     STOP
  ENDIF
  ALPHAS2 = ALF
  RETURN
END subroutine aspdflib

! ========================================================================
SUBROUTINE CtLhAlphaNewSET(MC,MB,MT,Q0,ALPHA0,IORDER,IMODE)
  ! call to set quark masses for alpha_s, and choose lambda or its
  ! equivalent to make alpha_s take the value alpha0 at scale Q0.
  IMPLICIT NONE
  include 'parmsetup.inc'
  DOUBLE PRECISION MC, MB, MT, Q0, ALPHA0
  INTEGER IORDER, IMODE

  DOUBLE PRECISION UDSCBT, QQ0, AALPHA0
  INTEGER IIORDER, IIMODE
  COMMON /QMASSES/ UDSCBT(6), IIMODE, IIORDER
  COMMON /ALSCALE/ QQ0(nmxset), AALPHA0(nmxset)
  integer iset
  double precision Adummy(nmxset)
  integer Nfl(nmxset), Idummy(nmxset)
  common / QCDtable /  Adummy, Nfl, Idummy

  call getnset(iset)

  if((imode .lt. 1) .or. (imode .gt. 3)) then
     print *,'CtLhAlphaNewSET: fatal imode=',imode
     stop
  endif

  IIMODE = IMODE
  QQ0(iset) = Q0
  AALPHA0(iset) = ALPHA0
  IIORDER = IORDER

  UDSCBT(1) = .005D0
  UDSCBT(2) = .010D0
  UDSCBT(3) = .300D0
  UDSCBT(4) = MC
  UDSCBT(5) = MB
  UDSCBT(6) = MT

  ! set artificial quark masses, if necessary, in alpha_s to enforce
  ! the requested maximum number of flavors...
  if(Nfl(iset) .le. 5) UDSCBT(6) = 6.d99
  if(Nfl(iset) .le. 4) UDSCBT(5) = 5.d99
  if(Nfl(iset) .le. 3) UDSCBT(4) = 4.d99
  if(Nfl(iset) .le. 2) UDSCBT(3) = 3.d99
  if(Nfl(iset) .le. 1) UDSCBT(2) = 2.d99
  if(Nfl(iset) .le. 0) UDSCBT(1) = 1.d99

  RETURN
END SUBROUTINE CtLhAlphaNewSET

FUNCTION CtLhAlphaNew(Q)
  IMPLICIT NONE
  DOUBLE PRECISION CtLhAlphaNew, Q
  DOUBLE PRECISION Q2, CtLhQALPHAS, UDSCBT
  integer nf,ier
  INTEGER IIMODE, IIORDER
  COMMON /QMASSES/ UDSCBT(6), IIMODE, IIORDER
  if ((iimode .ge. 1) .and. (iimode .le. 3)) then
     Q2=Q*Q
     nf=6
     if (Q2.lt. UDSCBT(6)**2) nf=5
     if (Q2.lt. UDSCBT(5)**2) nf=4
     if (Q2.lt. UDSCBT(4)**2) nf=3
     if (Q2.lt. UDSCBT(3)**2) nf=2
     if (Q2.lt. UDSCBT(2)**2) nf=1
     if (Q2.lt. UDSCBT(1)**2) nf=0

     ! external maximum number of flavors -- typically, nfmax=5 so
     ! top quark is not a parton even at large Q...
     CtLhAlphaNew=CtLhQALPHAS(Q2,nf,ier)
     if(ier .ne. 0) then
        print *,'warning in CtLhAlphaNew, Q=',Q,' nf=',nf,' ier=',ier,' CtLhAlphaNew=',CtLhAlphaNew
     endif
  else
     print *,'CtLhAlphaNew: undefined mode=',iimode
     stop
  endif

  return
end FUNCTION CtLhAlphaNew

FUNCTION CtLhQALPHAS(QQ2,NF,IERR)
  IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  include 'parmsetup.inc'
  COMMON /ALSCALE/ Q0(nmxset), ALPHA0(nmxset)
  COMMON /QMASSES/ UDSCBT(6), IIMODE, IIORDER

  call getnset(iset)

  Q02 = Q0(iset)**2
  ALP0 = ALPHA0(iset)
  IOR = IIORDER

  NFFF = NF
  CtLhQALPHAS = CtLhA0TOA1(QQ2,Q02,ALP0,IOR,NFFF,IERR)

  RETURN
END FUNCTION CtLhQALPHAS

FUNCTION CtLhA0TOA1(QSU,QS0,AS0,IORD,NFF,IERR)
  IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  COMMON /QMASSES/ UDSCBT(6), IIMODE, IIORDER
  QS1   = QSU
  QMU0  = SQRT(QS0)
  QMU1  = SQRT(QS1)

  ! CHECK: explicit initialisation of NF{0,1} (by AB)
  NF0 = 0
  NF1 = 0
  DO I = 1, 6
     IF(QMU0.GE.UDSCBT(I)) NF0 = I
     IF(QMU1.GE.UDSCBT(I)) NF1 = I
  ENDDO

  IF(NF1.LT.NF0) THEN
     IST = -1
     JST =  0
  ELSE
     IST = 1
     JST = 1
  ENDIF

  ALFA0 = AS0
  Q00   = QS0

  IERR = 0
  DO NF = NF0,NF1,IST
     IF(NF.NE.NF1) THEN
        Q21 = UDSCBT(NF+JST)**2
     ELSE
        Q21 = QS1
     ENDIF
     IMODE = IIMODE
     ALFA1 = CtLhALPHAR(Q21,Q00,ALFA0,NF,IORD,IMODE,JERR)
     IERR = IERR + JERR!IERR is sum of all errors
     ALFA0 = ALFA1
     Q00   = Q21
  END DO

  CtLhA0TOA1 = ALFA0
  NFF    = NF1

  RETURN
END FUNCTION CtLhA0TOA1

FUNCTION CtLhALPHAR(QSQ,QS0,AS0,NF,IORD,IMODE,IERR)
  ! calculate ALPHAS FROM RGE GIVEN AS0 AT QS0.
  !
  ! IORD=1: LEADING ORDER DEFINED BY
  !                 Q*d(alpha)/d(Q) = c1*alpha**2
  !
  ! IORD=2,IMODE=1: QCD NUM CHOICE DEFINED BY
  !                 Q*d(alpha)/d(Q) = c1*alpha**2 + c2*alpha**3
  !
  ! IORD=2,IMODE=2: AD HOC ALTERNATIVE DEFINED BY
  !                 Q*d(alpha)/d(Q) = c1*alpha**2 / (1 - (c2/c1)*alpha)
  !
  ! IORD=2,IMODE=3: TRADITIONAL CTEQ CHOICE DEFINED BY
  !                 ALPHA = c3*(1 - c4*log(L)/L)/L, WHERE L=log((Q/lambda)**2)
  !
  ! c1 = -beta0/(2*pi)     where beta0 =  11. -  (2./3.)*nf
  ! c2 = -beta1/(8*pi**2)  where beta1 = 102. - (38./3.)*nf
  !
  ! c3 = -2/c1
  ! c4 = -2*c2/c1**2
  !
  IMPLICIT DOUBLE PRECISION (A-H,O-Z)

  DATA PI / 3.14159265358979d0 /

  BET0 = 11.d0 -(2*NF)/3.d0
  BET1 = 102.d0 - (38*NF)/3.d0
  B0   = BET0/(4.d0*PI)
  B1   = BET1/(4.d0*PI*BET0)
  IERR = 0

  TERM0 = 1.d0/AS0+B0*LOG(QSQ/QS0)
  IF (TERM0.LE.0.) THEN
     CtLhALPHAR = 100.
     IERR   = 1
     PRINT *,'CtLhALPHAR WARNING: RETURN 100.'
     RETURN
  ENDIF
  ALFA0 = 1.d0/TERM0

  ! ORDER=1 IS LEADING ORDER, WHICH IS SAME FOR ALL IMODE.
  IF (IORD.EQ.1) THEN
     CtLhALPHAR = ALFA0
     RETURN
  ELSEIF(IORD.NE.2) THEN
     PRINT *,'FATAL ERROR: UNDEFINED ORDER IN CtLhALPHAR'
     STOP
  ENDIF

  ! QCD NUM CHOICE: Q*d(alpha)/d(Q) = c1*alpha**2 + c2*alpha**3
  IF(IMODE .EQ. 1) THEN

     ! use Newton's method to solve the equation, instead of the
     ! simple iterative method used in qcdnum (jcp 9/01)
     DO ITER = 1, 20
        ARG   = (1.d0/ALFA0+B1)/(1.d0/AS0+B1)
        IF(ARG.LE.0.) THEN
           CtLhALPHAR = 10.
           IERR   = 1
           PRINT *,'CtLhALPHAR WARNING: RETURN 10.'
           RETURN
        ENDIF

        TERM  = TERM0 + B1*LOG(ARG) - 1.d0/ALFA0
        ALFA1 = ALFA0/(1.d0 + ALFA0*(1.d0 + B1*ALFA0)*TERM)

        IF(ABS(ALFA1-ALFA0).LT.1.E-12) GOTO 20
        ALFA0 = ALFA1
     ENDDO

     CtLhALPHAR = 10.
     IERR   = 1
     RETURN

20   CONTINUE
     CtLhALPHAR = ALFA1
     RETURN

     ! AD HOC ALTERNATIVE: Q*d(alpha)/d(Q) = c1*alpha**2 / (1 - (c2/c1)*alpha)
  ELSEIF(IMODE .EQ. 2) THEN

     ! first get a good starting point, to be sure Newton's method doesn't go
     ! to the wrong root.
     BEST = 9.d99
     ! CHECK: adding explicit initialisation of ALBST (by AB)
     ALBST = ALFA0
     DO ITRY = 0, 20
        IF(ITRY.NE.0) ALFA0 = (1./B1)*(ITRY-0.5D0)/20.D0
        F = -1.d0/ALFA0 + TERM0 - B1*LOG(ALFA0/AS0)
        IF(ABS(F) .LT. BEST) THEN
           BEST = ABS(F)
           ALBST = ALFA0
        ENDIF
     ENDDO

     ALFA0 = ALBST
     DO ITER=1, 20
        F = -1.d0/ALFA0 + TERM0 - B1*LOG(ALFA0/AS0)
        ALFA1 = ALFA0/(1.d0 + ALFA0*F/(1.d0 - B1*ALFA0))
        IF(ABS(ALFA1-ALFA0) .LT. 1.E-12) GOTO 30
        ALFA0 = ALFA1
     ENDDO

     CtLhALPHAR = 10.
     IERR   = 1
     RETURN

30   CONTINUE
     CtLhALPHAR = ALFA1
     RETURN

     ! TRADITIONAL CTEQ CHOICE: ALPHA = c3*(1 - c4*log(L)/L)/L, WHERE L=log((Q/lambda)**2)
  ELSEIF(IMODE .EQ. 3) THEN

     Z = -LOG(B0*AS0)
     TMP = BET1/BET0**2

     DO ITER = 1, 20
        F = EXP(Z) - (1.D0 - TMP*Z*EXP(-Z))/(B0*AS0)
        FPRI = EXP(Z)  + TMP*(1.D0-Z)*EXP(-Z)/(B0*AS0)
        ZNEW = Z - F/FPRI
        IF(ABS(Z-ZNEW) .LT. 1.E-10) GOTO 40
        Z = ZNEW
     ENDDO

     CtLhALPHAR = 10.
     IERR   = 1
     RETURN

40   CONTINUE
     XLAMSQ = QS0 * EXP(-EXP(ZNEW))

     XL = LOG(QSQ/XLAMSQ)

     ! return a fixed value if no solution...
     IF (XL .LE. 0.D0) THEN
        CtLhALPHAR = 10.D0
        IERR = 1
        RETURN
     ENDIF

     CtLhALPHAR = (1.d0 - TMP*LOG(XL)/XL)/(B0*XL)

     ! place a cutoff if comes out very large...
     if (CtLhALPHAR .gt. 10.d0) then
        CtLhALPHAR = 10.d0
        IERR = 1
     endif

     RETURN

  ELSE
     PRINT *,'FATAL UNDEFINED IMODE=',IMODE
     STOP
  ENDIF

  RETURN
END FUNCTION CtLhALPHAR

FUNCTION CtLhALPInew (AMU)
  ! Returns effective g**2/(4pi**2) = alpha/pi.
  IMPLICIT DOUBLE PRECISION (A-H, O-Z)
  data pi / 3.14159265358979d0 /
  q = amu
  alpha = CtLhAlphaNew(q)
  CtLhalpinew = alpha/pi
  RETURN
END FUNCTION CtLhALPInew

subroutine CTEQ6NewAlpha(nset,mem)
  IMPLICIT DOUBLE PRECISION (A-H, O-Z)
  include 'parmsetup.inc'
  common / QCDtable /  Alambda(nmxset), Nfl(nmxset), Iorder(nmxset)
  dimension parms(2)
  q0 = 91.188d0
  call listPDF(nset,mem,parms)
  alpha0 = parms(1)
  ximode = parms(2)
  imode = int(ximode)
  iiorder = iorder(nset)

  ! **********************************************************
  ! the input data file should probably specify a very large
  ! value for xmt, because we never allow top quark as a parton
  ! in the PDF fitting, so there are never more than 5 active
  ! flavors.  Presume it is most consistent therefore to
  ! also keep top quark loop out of running of alpha.
  ! **********************************************************

  call GetQmassM(nset,4,cmass)
  call GetQmassM(nset,5,bmass)
  call GetQmassM(nset,6,tmass)
  call CtLhAlphaNewSET(cmass,bmass,tmass,Q0,ALPHA0,IIORDER,IMODE)
  RETURN
END subroutine CTEQ6NewAlpha

subroutine getnset(nset)
  integer iset,nset
  save iset
  nset = iset
  return

  entry setnset(nset)
  iset = nset
  return
end subroutine getnset

subroutine getnmem(nset,nmem)
  include 'parmsetup.inc'
  integer nmem,nset,member(nmxset)
  save member
  nmem = member(nset)
  return

  entry setnmem(nset,nmem)
  member(nset) = nmem
  return
end subroutine getnmem

subroutine alphacteq5f34(nflav,alphas,q)
  IMPLICIT DOUBLE PRECISION (A-H, O-Z)
  parameter(pi=3.14159265358979323846d0)

  alphas = pi*CtLhALPI34(nflav,q)
  return
end subroutine alphacteq5f34

FUNCTION CtLhALPI34 (nflav,AMU)
  IMPLICIT DOUBLE PRECISION (A-H, O-Z)
  COMMON / LhCtCWZPRM / ALAM(0:9), AMHAT(0:9), AMN, NHQ
  COMMON / LhCtQCDPAR_LHA / AL, NF, NORDER, SET
  LOGICAL SET
  PARAMETER (D0 = 0.D0, D1 = 1.D0, BIG = 1.0D15)
  DATA IW1, IW2 / 2*0 /
  IF(.NOT.SET) CALL CtLhLAMCWZ
  NEFF = LhCtNFL(AMU)

  if(neff.gt.nflav) neff=nflav

  ALM  = ALAM(NEFF)
  if(neff.eq.3) alm = 0.395
  if(neff.eq.4) alm = 0.309
  CtLhALPI34 = CtLhALPQCD (NORDER, NEFF, AMU/ALM, IRT)
  IF (IRT .EQ. 1) THEN
     CALL CtLhWARNR (IW1, 'AMU < ALAM in CtLhALPI34', 'AMU', AMU,ALM, BIG, 1)
  ELSEIF (IRT .EQ. 2) THEN
     CALL CtLhWARNR(IW2,'CtLhALPI34 > 3; Be aware!','CtLhALPI34',CtLhALPI34, D0, D1, 0)
  ENDIF
  RETURN
END FUNCTION CtLhALPI34

function CtLhalgluino(Q)
  !     51  mg=50  GeV  WITH TOP MASS OF 174
  !     52  mg=15  GeV
  !     53  mg=25  GeV
  !     54  mg=35  GeV
  !     55  mg=50  GeV
  !     56  mg=90  GeV
  !     57  mg=100  GeV
  !     58  mg=200  GeV
  !     59  mg=inf  GeV

  IMPLICIT DOUBLE PRECISION (A-H, O-Z)
  Parameter (nsets=8)
  Dimension xmass(6), gArray(nsets), nfArray(nsets)
  Dimension xlamStrange(nsets),xlamCharm(nsets),xlamBottom(nsets),xlamGluino(nsets),xlamTop(nsets)
  data iorder /2/
  Data xmass / 0.0, 0.0, 0.5d0, 1.3d0, 4.5d0, 174.0d0/
  Data gArray / 15.0d0, 25.0d0, 35.0d0, 50.0d0, 90.0d0, 100.0d0, 200.0d0, 1.0d99/  !*** Last value = Infinity
  Data  xlamStrange /  0.240257, 0.272782, 0.296194, 0.322873,  0.371374,  0.372537, 0.372537, 0.372537/
  Data  xlamCharm   /  0.197153, 0.227834, 0.250338, 0.276386, 0.324772, 0.325947, 0.325947, 0.325947/
  Data  xlamBottom  /  0.128981, 0.151553, 0.168364, 0.188074,  0.225349, 0.226264, 0.226264, 0.226264/
  Data  xlamGluino  / 0.005,  0.005,  0.005,  0.005,  0.005, 0.00480354,  0.00355387,  0.0/

  Data  xlamTop     /  0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/
  Data nfArray /5,5,5,5,5,5,5,5/

  ! 3456789012345678901234567890123456789012345678901234567890123456789012

  zmass=91.2

  pi=4.0d0*atan(1.0d0)

  call getnset(iset)
  call getnmem(iset,imem)

  nfMax=nfArray(imem)
  nf=3
  if(Q.ge.xmass(4))  nf=4
  if(Q.ge.xmass(5))  nf=5
  if(Q.ge.xmass(6))  nf=6  !*** Top for Iset=51 only
  if(nf.gt.nfMax) nf=nfMax

  gmass=gArray(imem+1)
  ng=0
  if(Q.ge.gmass) ng=1

  xlam = xlamStrange(imem+1)
  if(Q.ge.xmass(4))  xlam = xlamCharm(imem+1)
  if(Q.ge.xmass(5))  xlam = xlamBottom(imem+1)
  if(Q.ge.gmass   )  xlam = xlamGluino(imem+1)

  if((Q.ge.xmass(6)).and.(nfMax.ge.6))  xlam = xlamTop(imem+1)

  nsquark=0
  b0=11. - 2./3.*nf - 2.*ng- 1./6.*nsquark
  b1=102.-38./3.*nf-48.*ng-11./3.*nsquark+13./3.*ng*nsquark
  if(iorder.eq.1) b1=0

  xlog=Log(Q**2/xlam**2)

  tmp= 4.*pi*( 1./(b0*xlog) - b1*Log(xlog)/(b0**3*xlog**2))

  CtLhalgluino=tmp
  Return
End function CtLhalgluino


!made by PJPark

!123456
      real, allocatable :: eigup(:,:),eigdn(:,:),feigup(:,:)
      real, allocatable :: feigdn(:,:),xrk(:,:), xk(:,:), kval(:)
      integer :: nband, nks, nline, istart, nrem, check, line, next_line
      real :: k, kpt, dis_k
      real :: fermi,spin
      real :: b11, b12, b13, b21, b22, b23, b31, b32, b33
      real :: c11, c12, c13, c21, c22, c23, c31, c32, c33
      real :: a11, a12, a13, a21, a22, a23, a31, a32, a33
      real :: Pi
!   please remember the number of writting field in the format should be larger than the number of bands
!123456
      OPEN(1,file='band.dat')
      read(1,*) fermi
      write(6,*) "spin unpolar(type '0') or spin polar(type '1')"
      write(6,*) "fermi level"
      write(6,*) "b vector"

      open(17,file='CONTCAR')
      read(17,*)
      read(17,*)
      read(17,*) a11, a12, a13
      read(17,*) a21, a22, a23
      read(17,*) a31, a32, a33

      c11 = a22*a33 - a23*a32
      c12 = a23*a31 - a21*a33
      c13 = a21*a32 - a22*a31
      c21 = a32*a13 - a33*a12
      c22 = a33*a11 - a31*a13
      c23 = a31*a12 - a32*a11
      c31 = a12*a23 - a13*a22
      c32 = a13*a21 - a11*a23
      c33 = a11*a22 - a12*a21

      Pi = Atan(1.0)*4

      b11 = 2*Pi*c11/(a11*c11 + a12*c12 + a13*c13)
      b12 = 2*Pi*c12/(a11*c11 + a12*c12 + a13*c13)
      b13 = 2*Pi*c13/(a11*c11 + a12*c12 + a13*c13)
      b21 = 2*Pi*c21/(a21*c21 + a22*c22 + a23*c23)
      b22 = 2*Pi*c22/(a21*c21 + a22*c22 + a23*c23)
      b23 = 2*Pi*c23/(a21*c21 + a22*c22 + a23*c23)
      b31 = 2*Pi*c31/(a31*c31 + a32*c32 + a33*c33)
      b32 = 2*Pi*c32/(a31*c31 + a32*c32 + a33*c33)
      b33 = 2*Pi*c33/(a31*c31 + a32*c32 + a33*c33)

      open(15,file='EIGENVAL')
      read(15,*) c1, c2, c3, spin

       If(spin.eq.1) then
      do line=1,4
        read(15,*)
        next_line=next_line+line
      enddo
      read(15,*)Nelectron,nk,nband
      allocate (feigup(nk,nband),eigup(nk,nband))
      allocate (xrk(nk,3),xk(nk,3),kval(nk))

      do i =1,nk
         read(15,*)
         read(15,*)xrk(i,1),xrk(i,2),xrk(i,3),tmp123
         do j = 1,nband
            read(15,*)itmp,eigup(i,j)
         enddo
      enddo

      xk(:,1) = b11*xrk(:,1) + b21*xrk(:,2) + b31*xrk(:,3)
      xk(:,2) = b12*xrk(:,1) + b22*xrk(:,2) + b32*xrk(:,3)
      xk(:,3) = b13*xrk(:,1) + b23*xrk(:,2) + b33*xrk(:,3)

      k = 0.0
      kpt = 0.0
      kval(1) = 0.0
      do i=2,nk
         k=sqrt((xk(i,1)-xk(i-1,1))**2 + (xk(i,2)-xk(i-1,2))**2 + &
                 (xk(i,3)-xk(i-1,3))**2)
         kpt = kpt + k
         kval(i) = kpt
      enddo

      feigup(:,:) = eigup(:,:) - fermi

      open(24,file='band.txt')
 118  format(f14.7,3x,f14.7)
        write(24,*) '#kval, total'
      do j = 1, nband
      do i = 1, nk
          write(24,118)kval(i), feigup(i,j)
      enddo
          write(24,*)
      enddo

       else

      read(15,*)
      read(15,*)
      read(15,*)
      read(15,*)
      read(15,*)Nelectron,nk,nband
      allocate (feigup(nk,nband),feigdn(nk,nband),eigup(nk,nband))
      allocate (eigdn(nk,nband),xk(nk,3),xrk(nk,3),kval(nk))

      do i =1,nk
         read(15,*)
         read(15,*)xrk(i,1),xrk(i,2),xrk(i,3),tmp123
         do j = 1,nband
            read(15,*)itmp,eigup(i,j),eigdn(i,j)
         enddo
      enddo

      xk(:,1) = b11*xrk(:,1) + b21*xrk(:,2) + b31*xrk(:,3)
      xk(:,2) = b12*xrk(:,1) + b22*xrk(:,2) + b32*xrk(:,3)
      xk(:,3) = b13*xrk(:,1) + b23*xrk(:,2) + b33*xrk(:,3)

      k = 0.0
      kpt = 0.0
      kval(1) = 0.0
      do i=2,nk
         k=sqrt((xk(i,1)-xk(i-1,1))**2 + (xk(i,2)-xk(i-1,2))**2 + &
                (xk(i,3)-xk(i-1,3))**2)
         kpt = kpt + k
         kval(i) = kpt
      enddo

      feigup(:,:) = eigup(:,:) - fermi
      feigdn(:,:) = eigdn(:,:) - fermi

       open(24,file='band.txt')
120  format(f14.7,3x,f14.7,3x,f14.7)
        write(24,*) '#kval, up, down'
      do j = 1, nband
      do i = 1, nk
          write(24,120)kval(i),feigup(i,j),feigdn(i,j)
      enddo
          write(24,*)
      enddo

      endif

      stop

      end


      subroutine evolve_dgtheta(ctfm,ctfmp,n_Athth,n_B,n_alpha,n_beta,n_
     &divbeta,np1_Athth,np1_B,np1_alpha,np1_beta,np1_divbeta,x,Nx,ht,hx,
     &myzero,vee,zepsdis,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 ht
      real*8 hx
      real*8 myzero
      real*8 vee
      real*8 zepsdis
      real*8 ctfm(Nx)
      real*8 ctfmp(Nx)
      real*8 n_Athth(Nx)
      real*8 n_B(Nx)
      real*8 n_alpha(Nx)
      real*8 n_beta(Nx)
      real*8 n_divbeta(Nx)
      real*8 np1_Athth(Nx)
      real*8 np1_B(Nx)
      real*8 np1_alpha(Nx)
      real*8 np1_beta(Nx)
      real*8 np1_divbeta(Nx)
      real*8 x(Nx)
      integer phys_bdy(2)
      real*8 res(Nx)
      real*8 qb
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = 0.1D1 - 0.1D1 * myzero * x(i)
      res(i)=qb
      end do
      endif
      if (phys_bdy(1) .eq. 1) then
      do i=2, 2, 1
      qb = np1_B(i) - 0.32D2 / (0.7D1 * zepsdis * hx + 0.64D2 * ht) * hx
     # * ht * (-0.5000000000000000D0 * (0.3D1 * np1_B(i - 1) - 0.4D1 * n
     #p1_B(i) + np1_B(i + 1)) / hx + 0.3125000000000000D-1 * zepsdis / h
     #t * (0.7D1 * np1_B(i) + np1_B(i + 2) - 0.4D1 * np1_B(i + 1) - 0.4D
     #1 * np1_B(i - 1)) + 0.3125000000000000D-1 * zepsdis / ht * (0.7D1
     #* n_B(i) + n_B(i + 2) - 0.4D1 * n_B(i + 1) - 0.4D1 * n_B(i - 1)))
      res(i)=qb
      end do
      endif
      do i=3, Nx-2, 1
      qb = np1_B(i) - 0.48D2 / (0.16D2 * vee * np1_divbeta(i) * ht * ctf
     #m(i) + 0.9D1 * zepsdis * ctfm(i) - 0.48D2 * np1_beta(i) * ht + 0.4
     #8D2 * ctfm(i)) * ht * ctfm(i) * ((-0.1D1 * n_B(i) + np1_B(i)) / ht
     # + 0.3333333333333333D0 * vee * np1_divbeta(i) * np1_B(i) - 0.2500
     #000000000000D0 / ctfmp(i) * (-0.1D1 * np1_B(i - 1) + np1_B(i + 1))
     # / hx * np1_beta(i) + np1_Athth(i) * np1_alpha(i) - 0.1D1 / ctfm(i
     #) * np1_B(i) * np1_beta(i) + 0.3333333333333333D0 * vee * n_divbet
     #a(i) * n_B(i) - 0.2500000000000000D0 / ctfmp(i) * (-0.1D1 * n_B(i
     #- 1) + n_B(i + 1)) / hx * n_beta(i) + n_Athth(i) * n_alpha(i) - 0.
     #1D1 / ctfm(i) * n_B(i) * n_beta(i) + 0.3125000000000000D-1 * zepsd
     #is / ht * (0.6D1 * np1_B(i) + np1_B(i + 2) + np1_B(i - 2) - 0.4D1
     #* np1_B(i + 1) - 0.4D1 * np1_B(i - 1)) + 0.3125000000000000D-1 * z
     #epsdis / ht * (0.6D1 * n_B(i) + n_B(i + 2) + n_B(i - 2) - 0.4D1 *
     #n_B(i + 1) - 0.4D1 * n_B(i - 1)))
      res(i)=qb
      end do
      do i=Nx-1, Nx-1, 1
      qb = np1_B(i) - 0.3D1 / (vee * np1_divbeta(i) * ht * ctfm(i) - 0.3
     #D1 * np1_beta(i) * ht + 0.3D1 * ctfm(i)) * ht * ctfm(i) * ((-0.1D1
     # * n_B(i) + np1_B(i)) / ht + 0.3333333333333333D0 * vee * np1_divb
     #eta(i) * np1_B(i) - 0.2500000000000000D0 / ctfmp(i) * (-0.1D1 * np
     #1_B(i - 1) + np1_B(i + 1)) / hx * np1_beta(i) + np1_Athth(i) * np1
     #_alpha(i) - 0.1D1 / ctfm(i) * np1_B(i) * np1_beta(i) + 0.333333333
     #3333333D0 * vee * n_divbeta(i) * n_B(i) - 0.2500000000000000D0 / c
     #tfmp(i) * (-0.1D1 * n_B(i - 1) + n_B(i + 1)) / hx * n_beta(i) + n_
     #Athth(i) * n_alpha(i) - 0.1D1 / ctfm(i) * n_B(i) * n_beta(i))
      res(i)=qb
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = np1_B(i) - 0.1D1 * ht * ((-0.1D1 * n_B(i) + np1_B(i)) / ht -
     #0.1D1 * myzero * x(i))
      res(i)=qb
      end do
      endif
      END


subroutine  PSOIL
  use simsphere_mod
  implicit none

  real :: OMA, SFFK, ZETA, XINCR, CORR
  integer :: NLVL1, I, II

!      INCLUDE 'modvars.h'

!  DATA OMA , SFFK / 0.0000727 , 4 /

  OMA = 0.0000727
  SFFK = 4.0
  ZETA = 0.0
  DZETA = 1.0

! Calc. LAMBDA, KAPPA & Volumetric Heat Capacity of the ground (CG).
! See manual for explanation of Lamda & Kappa.

! Rob Gillies 01/11/95
! The Thermal Inertia (TP) is entered in TI (Wm-2K-1) units
! Convert to cgs to be able to use regression equation derived
! from Sellers. This regression equation should be redone with
! MKS units which will then prevent all this cafuffle !!

!      INITIATE DUAL TI OPTION BY TNC DAJR, 15 MARCH, 1996

  IF (DUAL_TI == 'Y') THEN
    TP = TI_A * F + TI_B
  ENDIF

  TP = TP / 356.89466 ! Conversion to cal cm-1 K-1 s-1/2

! These are TP as a function of the surface moisture availability

!    TP  = F * 0.04000 + 0.02000 !  Toby's Generic Soil
!       TP  = F * 0.03000 + 0.03400 !  Toby's FIFE Soil
!       TP  = F * 0.04600 + 0.01400 !  Price's Sand
!       TP  = F * 0.03890 + 0.01290 !  Price's Clay
!        TP  = F * 0.04241 + 0.01349 !  Price's AVG(Sand,Clay)
!      TP  = F * 0.03000 + 0.00690 !  Price's Peat
!  TP = F * 0.04600 + 0.04500  !  Walnut Gultch

  LAMBDA = -0.00013 + 0.0502 * TP + 1.21 * TP**2
  KAPPA = LAMBDA**2 / TP**2
  KAPPA = KAPPA/1.0E4 ! NOW CONVERT TO MKS; TP ENTERED IN CGS
  LAMBDA = LAMBDA * 418.68
  CG = LAMBDA / KAPPA

! Find the best depth profile as a function of Kappa.
! The followig calcs are used in BELOW.  Creates a temp profile
! in the soil. Figure levels using scheme by Deardroff.

! DEL is set to numerically stable value.
! Initial temp's at substrate levels (NLVLS) calc'd based on
! a linear interpolation between OTEMP & BTEMP.

  NLVL1 = NLVLS + 1
  DEL = SQRT( SFFK * DELTA * KAPPA ) / ( EXP(DZETA) - 1 )
  XINCR = ( BTEMP - OTEMP ) / NLVLS
  TT(1) = OTEMP
  TT(NLVL1) = BTEMP

  do II = 2 , NLVLS
    TT(II) = TT(II-1) + XINCR
  end do

! Here the substrate spacing ( depth ) is being calc'd based on the
! on the scale depth (h = (1+z/d).

  do I = 1 , NLVL1
    Z(I) = (EXP( ZETA ) - 1 ) * DEL
    XFUN(I) = ( 1 + Z(I) / DEL )
    ZETA = ZETA + DZETA
  end do

! Correction of LAMBDA to account for reduction in temp wave in 1st
! soil layer. Consult manual for explanation.

! Label identified as unused by compiler
!** 7678 CONTINUE

  CORR = 2 / ( 1 + EXP( -Z(2) * SQRT( OMA / ( 2 * KAPPA ) ) ) )
  LAMBDA = CORR * LAMBDA

! Initialise W2G and WGG, the substrate water budget patameters.
! Deardorff (1978).

   W2G = WMAX * FSUB
   WGG = WMAX * F

   return
end