      module radint
      use tffitcode,only:ntwissfun
      integer*4 , parameter ::NRI=12,IPOUT=0,ML=30
      real*8 TWPIN(ntwissfun),TWPOT(ntwissfun),TWPMG(ntwissfun)
      real*8 ANG,E1,E2,TETA,RLE,RKL1,RKL2
      real*8  DL,DKL0,DKL1,DKL2,CKL0X,CKL0Y,CKL1X,CKL1Y
      real*8 FUNI(ML,NRI)
      real*8 TM(4,4),VM(4),TO(4,4),VO(4),TU(4,4),VU(4)

      contains
      subroutine INTGRL(LFNO)
      use tfstk
      use ffs
      use tffitcode
      use ffs_pointer
      use kyparam
      use macphys
      implicit none
      integer*4 ,intent(in)::LFNO
      integer*4 IB,IQ
*    TWP(1)=AX    (2)=BX    (3)=PHX
*    TWP(4)=AY    (5)=BY    (6)=PHY
*    TWP(7)=EX    (8)=EPX   (9)=EY   (10)=EPY
*    TWP(11)=R1   (12)=R2   (13)=R3  (14)=R4
*    TWP(16)=DX   (17)=DXP  (18)=DY  (19)=DYP
      type (sad_comp) ,pointer ::cmp
      real*8  RI(NRI),DI(NRI),DIEG(NRI)
      real*8 TOTANG,ENERGY,ALPHA,ALPHAX,ALPHAY,CHRX,CHRY,CO2,COPH,
     $     DAMPU,DAMPV,ELOSS,EMITU,EMITV,EPMAX,FREQ,PHIS,QX,QY,QS,
     $     RFV,RHARM,RKQ,RLT,SIG,SIGL,SIPH,TAUE,TAUQ,TAUU,TAUV,
     $     XI,OVERV,SYMPS
      integer*4 J,idc,ID,I,IR,IRP
      real*8 ,parameter ::
     $     COEFF=(elradi/(elmass**3)/3)*1e27,
     $     CO4=sqrt(55.d0/32.d0/sqrt(3.d0)*elradi/
     $     finest)/elmass*1e9,CO5=CO4**2
c      DATA COEFF/7.0394513D-6/
c      DATA CO4/1.2113938D-3/,CO5/1.4674773D-6/
*   NRI  NUMBER OF RADIATION INTEGRALS  MUST < 15 (DIM OF FUNI,DI,RI)
c
      IB=0
      IQ=0
      RI=0.d0
      RFV=0.d0
      RLT=0.d0
      TOTANG=0.d0
      ENERGY=amass/1e9*H0
      WRITE(LFNO,'(A/)')
     +'****************************************************************'
      WRITE(LFNO,'(A)')
     + '     RADIATION INTEGRALS OF A LATTICE WITH X-Y COUPLING'
      WRITE(LFNO,'(/A)')
     +'     CONTRIBUTIONS FROM SOLENOID MAGNETS ARE NOT included '
      WRITE(LFNO,'(A)') '              IN THIS VERSION.   1991.2.26 '
      WRITE(LFNO,'(A)') '                  Refurbished:  2019.10.10 '
      WRITE(LFNO,'(A)')
     +'****************************************************************'
c      WRITE(LFNO,'(/ A,I6)') 'NLAT =',NLAT
c      WRITE(LFNO,'(// A,A)') '           I1U      I2       I3   ',
c     +         '   I4U      I5U      I1V      I4V      I5V'
      DO 10 J=1,NLAT-1
        call compelc(j,cmp)
        idc=cmp%id
        ID=idtype(idc)
        DO 11 I=1,ntwissfun
         TWPIN(I)=TWISS(J,0,I)
         TWPMG(I)=TWPIN(I)
         IF(J.LT.NLAT) THEN
           TWPOT(I)=TWISS(J+1,0,I)
         ELSE
           TWPOT(I)=TWPIN(I)
         END IF
   11    CONTINUE
         DI=0.d0
         DIEG=0.d0
         CKL0X=0.
         CKL0Y=0.
         CKL1X=0.
         CKL1Y=0.
c         ID=IDTYPE(LATT(1,J))
         RLE=cmp%value(kytbl(kwL,ID))
c         RLE=RLIST(IDVAL(LATT(1,J))+1)
         RLT=RLT+RLE
c         WRITE(LFNO,'(A,2I5,1p2g13.5)') ' ELEMENT  ',J,ID,RLE,RLT
         select case (ID)
         case(icBEND)
            IB=IB+1
            ANG=cmp%value(ky_ANGL_BEND)
            E1=cmp%value(ky_E1_BEND)*ANG
            E2=cmp%value(ky_E2_BEND)*ANG
            TETA=cmp%value(ky_ROT_BEND)
c            ANG=RLIST(LATT(2,J)+2)
c            E1=RLIST(LATT(2,J)+3)*ANG
c            E2=RLIST(LATT(2,J)+4)*ANG
c            TETA=RLIST(LATT(2,J)+5)
            IF(ANG.EQ.0) GOTO 10
            IR=min(14,max(1,int(ABS(ANG)/0.002d0)))
            IRP=2*IR
            DL=RLE/IRP
            DKL0=ANG/IRP
            TOTANG=TOTANG+ANG
*      WRITE(LFNO,'(A,6F12.5)') ' BM ',ANG,E1,E2,RLE,TOTANG,RLT
            IF(IPOUT.EQ.1.AND.IB.LE.10) THEN
              WRITE(LFNO,'(// A,3F12.5)') PNAME(idc),RLE,RKL1,RLT
              WRITE(LFNO,'(/A,I4/ 10F8.3/ 1P,(10D8.1))')
     $             ' TWPIN ',J,TWPIN
              WRITE(LFNO,'(A,I4/ 10F8.3/ 1P,(10D8.1))')
     $             ' TWPOT ',J,TWPOT
              WRITE(LFNO,'(/ A/ 10F8.3/ 1P,(10D8.1))') ' TWPMG ',TWPMG
            END IF
            IF(E1.NE.0.) THEN
               CALL BEDGE(E1)
               CALL TEDGE(DIEG)
c               write(*,*)'bend-e1 ',i,E1,tu(1,1),tu(2,2)
               IF(IPOUT.EQ.1.AND.IB.LE.10)
     +         WRITE(LFNO,'(A/ 10F8.3/ 1P,(10D8.1))') ' TWPMG ',TWPMG
            ENDIF
            DO 100 I=1,IRP
               CALL BMAG(TETA)
c               write(*,*)'bend-i ',i,tu(1,1),tu(2,2)
               CALL TCAL(I,0)
               IF(IPOUT.EQ.1.AND.IB.LE.10)
     +         WRITE(LFNO,'(A/ 10F8.3/ 1P,(10D8.1))') ' TWPMG ',TWPMG
100         CONTINUE
               CALL TCAL(IRP+1,1)
            IF(E2.NE.0.) THEN
               CALL BEDGE(E2)
               CALL TEDGE(DIEG)
               IF(IPOUT.EQ.1.AND.IB.LE.10)
     +         WRITE(LFNO,'(A/ 10F8.3/ 1P,(10D8.1))') ' TWPMG ',TWPMG
            ENDIF
          case (icQUAD)
            IQ=IQ+1
            RKL1=cmp%value(ky_K1_QUAD)
            TETA=cmp%value(ky_ROT_QUAD)
c            RKL1=RLIST(LATT(2,J)+2)
c            TETA=RLIST(LATT(2,J)+4)
            IF(IPOUT.EQ.1.AND.IQ.LE.10) THEN
              WRITE(LFNO,'(// A,3F12.5)') PNAME(idc),RLE,RKL1,RLT
              WRITE(LFNO,'(/A,I4/ 10F8.3/ 1P,(10D8.1))')
     $             ' TWPIN ',J,TWPIN
              WRITE(LFNO,'(/A,I4/ 10F8.3/ 1P,(10D8.1))')
     $             ' TWPOT ',J,TWPOT
            END IF
            IF(RKL1.EQ.0) GOTO 10
            IR=int(ABS(RKL1)/0.02d0)
            IF(IR.EQ.0) IR=1
            IF(IR.GT.14) IR=14
            IRP=2*IR
            DL=RLE/IRP
            DKL1=RKL1/IRP
            DO 200 I=1,IRP
               IF(IPOUT.EQ.1.AND.IQ.LE.10)
     +         WRITE(LFNO,'(A/ 10F8.3/ 1P,(10D8.1))') ' TWPMG ',TWPMG
               CALL QUADRU(TETA,TWPMG(mfitdx),TWPMG(mfitdy))
               CALL TCAL(I,0)
200         CONTINUE
               CALL TCAL(IRP+1,1)
               IF(IPOUT.EQ.1.AND.IQ.LE.10)
     +         WRITE(LFNO,'(A/ 10F8.3/ 1P,(10D8.1))') ' TWPMG ',TWPMG
         case (icSEXT)
            RKL2=cmp%value(ky_K_THIN)
            TETA=cmp%value(ky_ROT_THIN)
c            RKL2=RLIST(LATT(2,J)+2)
c            TETA=RLIST(LATT(2,J)+4)
*           WRITE(LFNO,'(A,3F12.5)') ' S  ',RLE,RKL2,RLT
            CALL SEXTU(TETA,TWPMG(mfitdx),TWPMG(mfitdy))
            IR=0
            CALL TCAL(1,0)
            IF(RLE.EQ.0.) THEN
               DL=0.2
               WRITE(LFNO,'(A)') ' L(SEXTUPOLE) EQ 0. SET L=0.2'
            ENDIF
         CASE (icCAVI)
            RFV=cmp%value(ky_VOLT_CAVI)
            RHARM=cmp%value(ky_HARM_CAVI)
            FREQ=cmp%value(ky_FREQ_CAVI)
c            RFV=RFV+RLIST(LATT(2,J)+2)
c            RHARM=RLIST(LATT(2,J)+3)
c            FREQ=RLIST(LATT(2,J)+5)
*           WRITE(LFNO,*) RLIST(LATT(2,J)+3),RLIST(LATT(2,J)+5)
         END SELECT
         IF(ID.EQ.icBEND.OR.ID.EQ.icQUAD.OR.ID.EQ.icSEXT) THEN
*      WRITE(LFNO,'( 7F10.3)') AX0,AX(J+1),BX0,BX(J+1),GX0,EX0,EX(J+1)
           DO I=1,NRI
             DI(I)=SYMPS(FUNI(1,I),IR)+DIEG(I)
             RI(I)=RI(I)+DI(I)
           enddo
c            WRITE(LFNO,'( A,8(1PD9.2))') PNAME(idc),
c     +           (DI(I),I=1,8)
         END IF
   10 CONTINUE
      QX=TWPOT(3)/(2*PI)
      QY=TWPOT(6)/(2*PI)
      WRITE(LFNO,'(//A)') '    SYNCHROTRON RADIATION INTEGRALS'
      IF(RHARM.EQ.0) RHARM=FREQ*RLT/CVELOC
      IF(FREQ.EQ.0) FREQ=RHARM*CVELOC/RLT
*     WRITE(LFNO,'(A,E12.4,A,E12.4)') ' P0 = ',P0,'   H0 = ',H0
*     BFIELD=ENERGY*1.0E9/(CVELOC*RHO)
*     RAMBDAC=18.64/(BFIELD*ENERGY*ENERGY)
      WRITE(LFNO,'(/ A,F9.3)') ' ENERGY (GeV)               = ',ENERGY
      WRITE(LFNO,'(A,F9.3)')   ' DP/P                       = ',DP0
      WRITE(LFNO,'(A,F9.3)')   ' TOTAL LENGTH (m)           = ',RLT
      TOTANG=TOTANG*180./PI
      WRITE(LFNO,'(A,F9.3)')   ' TOTAL BENDING ANGLE (DEG)  = ',TOTANG
      WRITE(LFNO,'(A,1pg15.7)')' TOTAL BENDING ANGLE (RAD)  = ',RI(11)
*     WRITE(LFNO,'(A,F9.4)') ' BFIELD (TESLA)             = ',BFIELD
*     WRITE(LFNO,'(A,F6.3)') ' LAMBDAC (A)               = ',RAMBDAC
      RFV=RFV/1000.
      WRITE(LFNO,'(A,1pg15.7)')' RF VOLTAGE (kV)            = ',RFV
      FREQ=FREQ*1.E-6
      WRITE(LFNO,'(A,F6.0)')   ' HARMONIC NUMBER            = ',RHARM
      WRITE(LFNO,'(A,F10.4)')  ' RF FREQUENCY (MHz)         = ',FREQ
      WRITE(LFNO,'(/ A)') ' RADIATION INTEGRALS  '
      WRITE(LFNO,'(2(A,1pg15.7))') '   I1X = ',RI(1),'    I1Y = ',RI(6)
      WRITE(LFNO,'(2(A,1pg15.7))') '   I2  = ',RI(2)
      WRITE(LFNO,'(2(A,1pg15.7))') '   I3  = ',RI(3)
      WRITE(LFNO,'(2(A,1pg15.7))') '   I4U = ',RI(4),'    I4V = ',RI(7)
      WRITE(LFNO,'(2(A,1pg15.7))') '   I5U = ',RI(5),'    I5V = ',RI(8)
      ELOSS=2.0D6*COEFF*RI(2)*ENERGY**4
      ALPHAX=RI(1)/RLT
      ALPHAY=RI(6)/RLT
      DAMPU=1.-RI(4)/RI(2)
      DAMPV=1.-RI(7)/RI(2)
      CO2=CVELOC*ENERGY**3*COEFF/RLT
      TAUU=1000.0/(CO2*(RI(2)-RI(4)))
      TAUV=1000.0/(CO2*(RI(2)-RI(7)))
      TAUE=1000.0/(CO2*(2*RI(2)+RI(4)+RI(7)))
      SIG=CO4*ENERGY*DSQRT(RI(3)/(2.*RI(2)+RI(4)+RI(7)))
      EMITU=CO5*ENERGY*ENERGY*RI(5)/(RI(2)-RI(4))
      EMITV=CO5*ENERGY*ENERGY*RI(8)/(RI(2)-RI(7))
      CHRX=-RI(9)/4.d0/PI
      CHRY=-RI(10)/4.d0/PI
      WRITE(LFNO,'(/ A,F8.5,A,F8.5)')
     +  ' NU-X-  = ',QX,'    NU-Y- = ',QY
      WRITE(LFNO,'(A,1pg12.4)') ' MOMENTUM COMPACTION FAC X  = ',ALPHAX
      WRITE(LFNO,'(A,1pg12.4)') ' MOMENTUM COMPACTION FAC Y  = ',ALPHAY
      WRITE(LFNO,'(A,1pG12.4)') ' ENERGY LOSS PER TURN (kV)  = ',ELOSS
      WRITE(LFNO,'(A,F12.8)') ' DU=1-I4U/I2                = ',DAMPU
      WRITE(LFNO,'(A,F12.8)') ' DV=1-I4V/I2                = ',DAMPV
      WRITE(LFNO,'(/ A)') ' DAMPING TIME CONSTANTS'
      WRITE(LFNO,'(A,1pg12.4)') '                TAUU (msec) = ',TAUU
      WRITE(LFNO,'(A,1pg12.4)') '                TAUV (msec) = ',TAUV
      WRITE(LFNO,'(A,1pg12.4)') '                TAUE (msec) = ',TAUE
      WRITE(LFNO,'(A,1Pg12.4)') ' ENERGY SPREAD (SIG) DE/E   = ',SIG
      WRITE(LFNO,'(A,1Pg12.4)') '            EMITTANCE U     = ',EMITU
      WRITE(LFNO,'(A,1Pg12.4)') '            EMITTANCE V     = ',EMITV
      IF (ELOSS.LE.RFV) THEN
         SIPH=ELOSS/RFV
         COPH=SQRT(1.-SIPH*SIPH)
         PHIS=PI-DATAN(SIPH/COPH)
         ALPHA=ALPHAX+ALPHAY
         QS=0.00039894228D0*DSQRT(RHARM*ALPHA*RFV*COPH/ENERGY)
         SIGL=1.D6*SIG*RLT*DSQRT((ALPHA*ENERGY)/(2*PI*RHARM*RFV*COPH))
         OVERV=RFV/ELOSS
         OVERV=SQRT(OVERV*OVERV-1)
         RKQ=2.0*(OVERV-ATAN(OVERV))
         EPMAX=SQRT(1.D-6*ELOSS*RKQ/(PI*ALPHA*RHARM*ENERGY))
         XI=0.5*(EPMAX/SIG)**2
         WRITE(LFNO,'(/ A,F12.6)')' NU-S                       = ',QS
         WRITE(LFNO,'(A,F12.6)')  ' BUCKET HIGHT   DEMAX/E     = ',EPMAX
         WRITE(LFNO,'(A,F12.6)')  ' NATURAL BUNCH LENGTH (mm)  = ',SIGL
         IF(XI.LT.100) THEN
         TAUQ=TAUE/1000.*DEXP(XI)/2./XI
         TAUQ=EXP(2.3026*TAUQ)
         WRITE(LFNO,'(A,1PD12.4)') ' QUANTUM LIFETIME(hours)    = ',TAUQ
         ELSE
         WRITE(LFNO,'(A,1PD12.4)') ' Q.LIFE IS TOO LONG      XI = ',XI
         END IF
      ELSE
         WRITE(LFNO,*) ' NOT ENOUGH RF VOLTS;  ELOSS,RFV = ',ELOSS,RFV
      END IF
      WRITE(LFNO,'(/ A,F12.6)') ' LINEAR CHROMATICITY GX     = ',CHRX
      WRITE(LFNO,'(A,F12.6)')   ' LINEAR CHROMATICITY GY     = ',CHRY
      END subroutine

      subroutine TCAL(I,IFLG)
      use tffitcode
      implicit none
      real*8, save:: R0(4,4),R0I(4,4)
      integer*4 I,IFLG
      real*8 CURV,CURV2,CURV3,GU,GV,RK1
      associate (
     $     AU=>TWPMG(mfitax),
     $     BU=>TWPMG(mfitbx),
     $     PU=>TWPMG(mfitnx),
     $     AV=>TWPMG(mfitay),
     $     BV=>TWPMG(mfitby),
     $     PV=>TWPMG(mfitny),
     $     EU=>TWPMG(mfitex),
     $     EPU=>TWPMG(mfitepx),
     $     EV=>TWPMG(mfitey),
     $     EPV=>TWPMG(mfitepy),
     $     R1=>TWPMG(mfitr1),
     $     R2=>TWPMG(mfitr2),
     $     R3=>TWPMG(mfitr3),
     $     R4=>TWPMG(mfitr4),
     $     DETR=>TWPMG(mfitdetr),
     $     DU=>TWPMG(mfitdx),
     $     DPU=>TWPMG(mfitdpx),
     $     DV=>TWPMG(mfitdy),
     $     DPV=>TWPMG(mfitdpy))
      IF(DL.EQ.0.) WRITE(6,'(A)') '  DL=0. IN TCAL '
      RK1=CKL1X/DL
      CURV=DSQRT(CKL0X*CKL0X+CKL0Y*CKL0Y)/DL
      GU=(1+AU*AU)/BU
      GV=(1+AV*AV)/BV
      IF(I.EQ.1) CALL R0CAL(R0,R0I)
      CURV2=CURV*CURV
      CURV3=CURV2*ABS(CURV)
      FUNI(I,1)=CKL0X*
     +          (R0I(1,1)*EU+R0I(1,2)*EPU+R0I(1,3)*EV+R0I(1,4)*EPV)
      FUNI(I,2)=CURV2*DL
      FUNI(I,3)=CURV3*DL
      IF(CURV.GT.0) THEN
      FUNI(I,4)=(CKL0X+2*CKL1X/CURV)*CURV2*(R0I(1,1)*EU+R0I(1,2)*EPU)
     +         +(CKL0Y-2*CKL1Y/CURV)*CURV2*(R0I(3,1)*EU+R0I(3,2)*EPU)
      ELSE
      FUNI(I,4)=0.
      END IF
      FUNI(I,5)=CURV3*(GU*EU*EU+2.*AU*EPU*EU+BU*EPU*EPU)*DL
c      write(*,*)'tcal-I5 ',funi(i,5),CURV3,DL
* 6: I1Y    7:I4Y     8:I5Y
      FUNI(I,6)=CKL0Y*
     +          (R0I(3,1)*EU+R0I(3,2)*EPU+R0I(3,3)*EV+R0I(3,4)*EPV)
      IF(CURV.GT.0) THEN
      FUNI(I,7)=(CKL0X+2*CKL1X/CURV)*CURV2*(R0I(1,3)*EV+R0I(1,4)*EPV)
     +         +(CKL0Y-2*CKL1Y/CURV)*CURV2*(R0I(3,3)*EV+R0I(3,4)*EPV)
      ELSE
      FUNI(I,7)=0.
      END IF
      FUNI(I,8)=CURV3*(GV*EV*EV+2.*AV*EPV*EV+BV*EPV*EPV)*DL
* 9:  CHROMX   10: CHROMY
c      FUNI(I,9)=(RK1+CURV2*0.d0)*BU*DL
c      FUNI(I,10)=-RK1*BV*DL
      FUNI(I,9) = GU*DL
      FUNI(I,10)= GV*DL
c      write(*,'(a,1p6g15.7)')'chrom ',RK1,CURV2,BU,BV,DL
      FUNI(I,11)=CKL0X
      FUNI(I,12)=CKL0Y
      IF(IFLG.EQ.1) RETURN
      CALL TMATRS(R0,R0I)
      CALL TWTRANS()
      end associate
      END subroutine

      subroutine BMAG(TETA1)
      implicit none
      real*8 TETA1,SI,CO,CURV
      CURV=DKL0/DL
      CALL ZEROV4(VM)
      CALL UNITM4(TM,1.d0)
      SI=DSIN(DKL0)
      CO=DCOS(DKL0)
      TM(1,1)=CO
      IF(CURV.NE.0.) THEN
        TM(1,2)=SI/CURV
        TM(2,1)=-SI*CURV
        VM(1)=(1-CO)/CURV
        VM(2)= SI
      ELSE
        TM(1,2)=DL
      END IF
      TM(2,2)=TM(1,1)
      TM(3,4)=DL
      CKL0X=DCOS(TETA1)*DKL0
      CKL0Y=-DSIN(TETA1)*DKL0
      CKL1X=0.
      CKL1Y=0.
      CALL TROT(TM,VM,TETA1,TO,VO)
      RETURN
      END subroutine

      subroutine TMATRS(R0,R0I)
      use tffitcode
      implicit none
      real*8 A(2,2),B(2,2),C(2,2),D(2,2),AI(2,2),CAI(2,2),ACI(2,2)
      real*8 RA1(2,2),RB1(2,2),RC1(2,2),RD1(2,2)
      real*8 TR(4,4),R0(4,4),R0I(4,4)
      real*8 DETCAI,SMU1,RMU1
      integer*4 J,K
      TR=matmul(TO,R0I)
c      WRITE(6,'(A)') 'TMATRS: TO, R0I, TR, R0, TU'
c      WRITE(6,'(8F10.4)') TO
c      WRITE(6,'(8F10.4)') R0I
c      WRITE(6,'(8F10.4)') TR
      CALL DM42(TR,A,B,C,D)
      CALL MINV2(A,AI)
      CALL MMUL2(C,AI,CAI)
      DETCAI=CAI(1,1)*CAI(2,2)-CAI(1,2)*CAI(2,1)
      IF(DETCAI.LT. 1.d0) THEN
         SMU1=1./(1.+DETCAI)
         RMU1=DSQRT(SMU1)
         CALL FMUL2(-RMU1,CAI,RC1)
         CALL SYMTR2(RC1,RB1)
         CALL UNITM2(RA1,RMU1)
         CALL UNITM2(RD1,RMU1)
         CALL CM24(RA1,RB1,RC1,RD1,R0)
         CALL R1INV(R0,R0I)
         DO J=1,2
           DO K=1,2
             TWPMG(10+K+2*(J-1))=RC1(J,K)
           enddo
         enddo
      ELSE
         SMU1=1./(1.+1./DETCAI)
         RMU1=DSQRT(SMU1)
         CALL MINV2(CAI,ACI)
         CALL FMUL2(-RMU1,ACI,RD1)
         CALL SYMTR2(RD1,RA1)
         CALL UNITM2(RB1,RMU1)
         CALL UNITM2(RC1,RMU1)
         CALL CM24(RA1,RB1,RC1,RD1,R0)
         CALL R2INV(R0,R0I)
         DO J=1,2
           DO K=1,2
             TWPMG(10+K+2*(2-J))=-RD1(J,K)
           enddo
         enddo
      END IF
      TU=matmul(R0,TR)
c      WRITE(6,'(8F10.4)') R0
c      WRITE(6,'(8F10.4)') TU
      VU=matmul(R0,VO)
c      CALL VMUL4(R0,VO,VU)
      RETURN
      END subroutine

      subroutine TWTRANS()
      use tffitcode
      use tmacro
      implicit none
      real*8 TTX(3,3),TTY(3,3),DX1(4)
      real*8 GX,GY,BX1,AX1,BY1,AY1,EX1,EPX1,EY1,EPY1
      associate (
     $     AX=>TWPMG(mfitax),
     $     BX=>TWPMG(mfitbx),
     $     PX=>TWPMG(mfitnx),
     $     AY=>TWPMG(mfitay),
     $     BY=>TWPMG(mfitby),
     $     PY=>TWPMG(mfitny),
     $     EX=>TWPMG(mfitex),
     $     EPX=>TWPMG(mfitepx),
     $     EY=>TWPMG(mfitey),
     $     EPY=>TWPMG(mfitepy),
     $     R1=>TWPMG(mfitr1),
     $     R2=>TWPMG(mfitr2),
     $     R3=>TWPMG(mfitr3),
     $     R4=>TWPMG(mfitr4),
     $     DETR=>TWPMG(mfitdetr),
     $     DX=>TWPMG(mfitdx:mfitdpy))
      TTX(1,1)=TU(1,1)*TU(1,1)
      TTX(1,2)=-2.*TU(1,1)*TU(1,2)
      TTX(1,3)=TU(1,2)*TU(1,2)
      TTX(2,1)=-TU(1,1)*TU(2,1)
      TTX(2,2)=1.+2.*TU(1,2)*TU(2,1)
      TTX(2,3)=-TU(1,2)*TU(2,2)
      TTX(3,1)=TU(2,1)*TU(2,1)
      TTX(3,2)=-2.*TU(2,2)*TU(2,1)
      TTX(3,3)=TU(2,2)*TU(2,2)
      TTY(1,1)=TU(3,3)*TU(3,3)
      TTY(1,2)=-2.*TU(3,3)*TU(3,4)
      TTY(1,3)=TU(3,4)*TU(3,4)
      TTY(2,1)=-TU(3,3)*TU(4,3)
      TTY(2,2)=1.+2.*TU(3,4)*TU(4,3)
      TTY(2,3)=-TU(3,4)*TU(4,4)
      TTY(3,1)=TU(4,3)*TU(4,3)
      TTY(3,2)=-2.*TU(4,4)*TU(4,3)
      TTY(3,3)=TU(4,4)*TU(4,4)
      GX=(1+AX*AX)/BX
      GY=(1+AY*AY)/BY
      BX1=TTX(1,1)*BX+TTX(1,2)*AX+TTX(1,3)*GX
      AX1=TTX(2,1)*BX+TTX(2,2)*AX+TTX(2,3)*GX
*     GX1=TTX(3,1)*BX+TTX(3,2)*AX+TTX(3,3)*GX
*     GX1=(1+AX1*AX1)/BX1
      BY1=TTY(1,1)*BY+TTY(1,2)*AY+TTY(1,3)*GY
      AY1=TTY(2,1)*BY+TTY(2,2)*AY+TTY(2,3)*GY
*     GY1=TTY(3,1)*BY+TTY(3,2)*AY+TTY(3,3)*GY
*     GY1=(1+AY1*AY1)/BY1
      EX1=TU(1,1)*EX+TU(1,2)*EPX+VU(1)
      EPX1=TU(2,1)*EX+TU(2,2)*EPX+VU(2)
      EY1=TU(3,3)*EY+TU(3,4)*EPY+VU(3)
      EPY1=TU(4,3)*EY+TU(4,4)*EPY+VU(4)
      AX=AX1
      AY=AY1
      BX=BX1
      BY=BY1
      EX=EX1
      EPX=EPX1
      EY=EY1
      EPY=EPY1
      DX1=matmul(TO,DX)
c      CALL VMUL4(TO,DX,DX1)
      DX(1)=DX1(1)+VO(1)*DP0
*    +      DP0*(R0I(1,1)*EX+R0I(1,2)*EPX+R0I(1,3)*EY+R0I(1,4)*EPY)
      DX(2)=DX1(2)+VO(2)*DP0
*    +      DP0*(R0I(2,1)*EX+R0I(2,2)*EPX+R0I(2,3)*EY+R0I(2,4)*EPY)
      DX(3)=DX1(3)+VO(3)*DP0
*    +      DP0*(R0I(3,1)*EX+R0I(3,2)*EPX+R0I(3,3)*EY+R0I(3,4)*EPY)
      DX(4)=DX1(4)+VO(4)*DP0
*    +      DP0*(R0I(4,1)*EX+R0I(4,2)*EPX+R0I(4,3)*EY+R0I(4,4)*EPY)
      end associate
      END subroutine

      subroutine QUADRU(TETA1,DX,DY)
      implicit none
      real*8 ,intent(in)::TETA1,DX,DY
      real*8 RK,P,S1,S2,S3,S4,TET2,DR,SQRK
      CALL ZEROV4(VM)
      CALL UNITM4(TM,1.d0)
      RK=DKL1/DL
      IF(RK.GE.0.) SQRK=DSQRT(RK)
      IF(RK.LT.0.) SQRK=DSQRT(-RK)
      P=SQRK*DL
      S1=DSIN(P)
      S2=DCOS(P)
      S3=DSINH(P)
      S4=DCOSH(P)
      IF (RK.GE.0.) THEN
*     QF TYPE
        TM(1,1)=S2
        TM(1,2)=S1/SQRK
        TM(2,1)=-SQRK*S1
        TM(2,2)=S2
        TM(3,3)=S4
        TM(3,4)=S3/SQRK
        TM(4,3)=SQRK*S3
        TM(4,4)=S4
        ELSE
*     QD TYPE
        TM(1,1)=S4
        TM(1,2)=S3/SQRK
        TM(2,1)=SQRK*S3
        TM(2,2)=S4
        TM(3,3)=S2
        TM(3,4)=S1/SQRK
        TM(4,3)=-SQRK*S1
        TM(4,4)=S2
      END IF
      TET2=TETA1*2.
      CKL0Y=-DKL1*(DX*DSIN(TET2)+DY*DCOS(TET2))
      CKL0X=DKL1*(DX*DCOS(TET2)-DY*DSIN(TET2))
*     CKL1X=DKL1*DCOS(TETA1)
*     CKL1Y=-CKL1X
      DR=DSQRT(DX*DX+DY*DY)
      IF(DR.GT.0.) THEN
        CKL1X=DKL1*DX/DR
        CKL1Y=-DKL1*DY/DR
      ELSE
        CKL1X=DKL1
        CKL1Y=-DKL1
      END IF
      CALL TROT(TM,VM,TETA1,TO,VO)
      RETURN
      END subroutine

      subroutine R0CAL(R0,R0I)
      use tffitcode
      implicit none
      real*8 RA0(2,2),RB0(2,2),RC0(2,2),RD0(2,2)
      real*8 R0(4,4),R0I(4,4)
      real*8 DETR,RMU0
      integer*4 J,K
c
      DO J=1,2
        DO K=1,2
          RC0(J,K)=TWPMG(10+K+2*(J-1))
        enddo
      enddo
      DETR=RC0(1,1)*RC0(2,2)-RC0(1,2)*RC0(2,1)
      IF(DETR.LE.1.) THEN
         RMU0=DSQRT(1.-DETR)
         CALL SYMTR2(RC0,RB0)
         CALL UNITM2(RA0,RMU0)
         CALL UNITM2(RD0,RMU0)
         CALL CM24(RA0,RB0,RC0,RD0,R0)
         CALL R1INV(R0,R0I)
      ELSE
*    DET(R)>1 CASE
         RA0(1,1)=TWPMG(13)/DETR
         RA0(1,2)=TWPMG(14)/DETR
         RA0(2,1)=TWPMG(11)/DETR
         RA0(2,2)=TWPMG(12)/DETR
         CALL SYMTR2(RA0,RD0)
         RMU0=DSQRT(1.-1./DETR)
         CALL UNITM2(RB0,RMU0)
         CALL UNITM2(RC0,RMU0)
         CALL CM24(RA0,RB0,RC0,RD0,R0)
         CALL R2INV(R0,R0I)
      ENDIF
      RETURN
      END subroutine

      subroutine TEDGE(DIEG)
      use tffitcode
      implicit none
      real*8 DIEG(*)
      real*8 R0(4,4),R0I(4,4)
      real*8 CURVX,CURVY
      associate (
     $     AU=>TWPMG(mfitax),
     $     BU=>TWPMG(mfitbx),
     $     PU=>TWPMG(mfitnx),
     $     AV=>TWPMG(mfitay),
     $     BV=>TWPMG(mfitby),
     $     PV=>TWPMG(mfitny),
     $     EU=>TWPMG(mfitex),
     $     EPU=>TWPMG(mfitepx),
     $     EV=>TWPMG(mfitey),
     $     EPV=>TWPMG(mfitepy),
     $     R1=>TWPMG(mfitr1),
     $     R2=>TWPMG(mfitr2),
     $     R3=>TWPMG(mfitr3),
     $     R4=>TWPMG(mfitr4),
     $     DETR=>TWPMG(mfitdetr),
     $     DU=>TWPMG(mfitdx),
     $     DPU=>TWPMG(mfitdpx),
     $     DV=>TWPMG(mfitdy),
     $     DPV=>TWPMG(mfitdpy))
      CURVX=CKL0X/DL
      CURVY=CKL0Y/DL
      CALL R0CAL(R0,R0I)
      DIEG(4)=DIEG(4)-(TO(2,1)*CURVX*(R0I(1,1)*EU+R0I(1,2)*EPU)
     +          -TO(4,3)*CURVY*(R0I(3,1)*EU+R0I(3,2)*EPU))
      DIEG(7)=DIEG(7)-(TO(2,1)*CURVX*(R0I(1,3)*EV+R0I(1,4)*EPV)
     +          -TO(4,3)*CURVY*(R0I(3,3)*EV+R0I(3,4)*EPV))
      DIEG(9)=DIEG(9)-TM(2,1)*BU
      DIEG(10)=DIEG(10)-TM(4,3)*BV
      CALL TMATRS(R0,R0I)
      CALL TWTRANS()
      end associate
      END subroutine

      subroutine BEDGE(EANG)
      implicit none
      real*8 EANG,CURV
      CURV=DKL0/DL
      CALL ZEROV4(VM)
      CALL UNITM4(TM,1.d0)
      TM(2,1)=CURV*DTAN(EANG)
      TM(4,3)=-CURV*DTAN(EANG)
      CALL TROT(TM,VM,TETA,TO,VO)
      CKL0X=DCOS(TETA)*DKL0
      CKL0Y=-DSIN(TETA)*DKL0
      CKL1X=0.
      CKL1Y=0.
      RETURN
      END subroutine

      subroutine SEXTU(TETA1,DX,DY)
      implicit none
      real*8 TETA1,DX,DY,SINT,COST
      CALL UNITM4(TM,1.d0)
      CALL UNITM4(TO,1.d0)
      CALL ZEROV4(VM)
      CALL ZEROV4(VO)
      SINT=DSIN(3.*TETA1)
      COST=DCOS(3.*TETA1)
      CKL0Y=-DKL2*(DX*DY*COST           +(DX*DX-DY*DY)/2.*SINT)
      CKL0X=DKL2*((DX*DX-DY*DY)/2.*COST-DX*DY*SINT)
*     CKL1X=DKL2*(2.*(DX-DY)*COST-2.*DX*SINT)
*     CKL1Y=-CKL1X
        CKL1X=DKL2*DX
        CKL1Y=-DKL2*DY
      RETURN
      END subroutine

      subroutine TROT (TM,VM,TETA,TO,VO)
      implicit none
      real*8 TM(4,4),VM(4),TO(4,4),VO(4)
      real*8 ROT(4,4),RINV(4,4),TS(4,4)
      real*8 TETA,CTET,STET
      CTET=DCOS(TETA)
      STET=DSIN(TETA)
      CALL UNITM4(ROT,CTET)
      CALL UNITM4(RINV,CTET)
      ROT(1,3)=-STET
      ROT(2,4)=-STET
      ROT(3,1)=STET
      ROT(4,2)=STET
      RINV(1,3)=STET
      RINV(2,4)=STET
      RINV(3,1)=-STET
      RINV(4,2)=-STET
      TS=matmul(TM,ROT)
      TO=matmul(RINV,TS)
      VO=matmul(RINV,VM)
c      CALL VMUL4(RINV,VM,VO)
      RETURN
      END subroutine

      end module


module test_rules
use fdeclarations
use fruit

implicit none

contains
subroutine sum_of_probability_values_should_be_1
real :: ref=1, ref0=0
real :: totalp
n=10
uvl(1:n)=(/0.000, 0.000, 1.000, 0.000, 0.000, 0.000, 0.000, 1.000, 0.000, 0.000/)
ul(1:n)=(/0.800, 0.600, 0.000, 1.000, 0.000, 0.000, 0.000, 0.000, 0.200, 1.000/)
um(1:n)=(/0.200, 0.400, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.800, 0.000/)
uh(1:n)=(/0.000, 0.000, 0.000, 0.000, 1.000, 0.000, 1.000, 0.000, 0.000, 0.000/)
uvh(1:n)=(/0.000, 0.000, 0.000, 0.000, 0.000, 1.000, 0.000, 0.000, 0.000, 0.000/)
dvs(1:n)=(/0.000, 0.000, 0.000, 0.000, 0.000, 1.000, 1.000, 0.333, 0.000, 0.000/)
ds(1:n)=(/0.000, 0.000, 1.000, 1.000, 0.000, 0.000, 0.000, 0.667, 0.000, 0.000/)
dm(1:n)=(/1.000, 1.000, 0.000, 0.000, 1.000, 0.000, 0.000, 0.000, 1.000, 0.000/)
dd(1:n)=(/0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 1.000/)
dvd(1:n)=(/0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/)
bld(1:n)=(/0.000, 0.000, 1.000, 1.000, 0.000, 0.000, 1.000, 0.000, 0.000, 1.000/)
ls(1:n)=(/0.000, 0.000, 0.000, 0.000, 0.000, 1.000, 0.000, 0.000, 0.000, 0.000/)
ss(1:n)=(/1.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/)
lg(1:n)=(/0.000, 1.000, 0.000, 0.000, 1.000, 0.000, 0.000, 0.000, 1.000, 0.000/)
mg(1:n)=(/0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/)
fg(1:n)=(/0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/)
sand(1:n)=(/0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 1.000, 0.000, 0.000/)
silt(1:n)=(/0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/)

call rules
do i=1,5
totalp=bayh1(i)+bayg1(i)+baym1(i)+bayp1(i)+bayb1(i)
call assert_equals(ref, totalp, 0.02)
end do

do i=8,10
totalp=bayh1(i)+bayg1(i)+baym1(i)+bayp1(i)+bayb1(i)
call assert_equals(ref, totalp, 0.02)
end do

do i=6,7
totalp=bayh1(i)+bayg1(i)+baym1(i)+bayp1(i)+bayb1(i)
call assert_equals(ref0, totalp, 0.02)
end do

end subroutine sum_of_probability_values_should_be_1
end module test_rules


!*==sstemr.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b SSTEMR
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SSTEMR + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE SSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
!                          M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK,
!                          IWORK, LIWORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          JOBZ, RANGE
!       LOGICAL            TRYRAC
!       INTEGER            IL, INFO, IU, LDZ, NZC, LIWORK, LWORK, M, N
!       REAL               VL, VU
!       ..
!       .. Array Arguments ..
!       INTEGER            ISUPPZ( * ), IWORK( * )
!       REAL               D( * ), E( * ), W( * ), WORK( * )
!       REAL               Z( LDZ, * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SSTEMR computes selected eigenvalues and, optionally, eigenvectors
!> of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
!> a well defined set of pairwise different real eigenvalues, the corresponding
!> real eigenvectors are pairwise orthogonal.
!>
!> The spectrum may be computed either completely or partially by specifying
!> either an interval (VL,VU] or a range of indices IL:IU for the desired
!> eigenvalues.
!>
!> Depending on the number of desired eigenvalues, these are computed either
!> by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are
!> computed by the use of various suitable L D L^T factorizations near clusters
!> of close eigenvalues (referred to as RRRs, Relatively Robust
!> Representations). An informal sketch of the algorithm follows.
!>
!> For each unreduced block (submatrix) of T,
!>    (a) Compute T - sigma I  = L D L^T, so that L and D
!>        define all the wanted eigenvalues to high relative accuracy.
!>        This means that small relative changes in the entries of D and L
!>        cause only small relative changes in the eigenvalues and
!>        eigenvectors. The standard (unfactored) representation of the
!>        tridiagonal matrix T does not have this property in general.
!>    (b) Compute the eigenvalues to suitable accuracy.
!>        If the eigenvectors are desired, the algorithm attains full
!>        accuracy of the computed eigenvalues only right before
!>        the corresponding vectors have to be computed, see steps c) and d).
!>    (c) For each cluster of close eigenvalues, select a new
!>        shift close to the cluster, find a new factorization, and refine
!>        the shifted eigenvalues to suitable accuracy.
!>    (d) For each eigenvalue with a large enough relative separation compute
!>        the corresponding eigenvector by forming a rank revealing twisted
!>        factorization. Go back to (c) for any clusters that remain.
!>
!> For more details, see:
!> - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
!>   to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
!>   Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
!> - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
!>   Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
!>   2004.  Also LAPACK Working Note 154.
!> - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
!>   tridiagonal eigenvalue/eigenvector problem",
!>   Computer Science Division Technical Report No. UCB/CSD-97-971,
!>   UC Berkeley, May 1997.
!>
!> Further Details
!> 1.SSTEMR works only on machines which follow IEEE-754
!> floating-point standard in their handling of infinities and NaNs.
!> This permits the use of efficient inner loops avoiding a check for
!> zero divisors.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] JOBZ
!> \verbatim
!>          JOBZ is CHARACTER*1
!>          = 'N':  Compute eigenvalues only;
!>          = 'V':  Compute eigenvalues and eigenvectors.
!> \endverbatim
!>
!> \param[in] RANGE
!> \verbatim
!>          RANGE is CHARACTER*1
!>          = 'A': all eigenvalues will be found.
!>          = 'V': all eigenvalues in the half-open interval (VL,VU]
!>                 will be found.
!>          = 'I': the IL-th through IU-th eigenvalues will be found.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] D
!> \verbatim
!>          D is REAL array, dimension (N)
!>          On entry, the N diagonal elements of the tridiagonal matrix
!>          T. On exit, D is overwritten.
!> \endverbatim
!>
!> \param[in,out] E
!> \verbatim
!>          E is REAL array, dimension (N)
!>          On entry, the (N-1) subdiagonal elements of the tridiagonal
!>          matrix T in elements 1 to N-1 of E. E(N) need not be set on
!>          input, but is used internally as workspace.
!>          On exit, E is overwritten.
!> \endverbatim
!>
!> \param[in] VL
!> \verbatim
!>          VL is REAL
!>
!>          If RANGE='V', the lower bound of the interval to
!>          be searched for eigenvalues. VL < VU.
!>          Not referenced if RANGE = 'A' or 'I'.
!> \endverbatim
!>
!> \param[in] VU
!> \verbatim
!>          VU is REAL
!>
!>          If RANGE='V', the upper bound of the interval to
!>          be searched for eigenvalues. VL < VU.
!>          Not referenced if RANGE = 'A' or 'I'.
!> \endverbatim
!>
!> \param[in] IL
!> \verbatim
!>          IL is INTEGER
!>
!>          If RANGE='I', the index of the
!>          smallest eigenvalue to be returned.
!>          1 <= IL <= IU <= N, if N > 0.
!>          Not referenced if RANGE = 'A' or 'V'.
!> \endverbatim
!>
!> \param[in] IU
!> \verbatim
!>          IU is INTEGER
!>
!>          If RANGE='I', the index of the
!>          largest eigenvalue to be returned.
!>          1 <= IL <= IU <= N, if N > 0.
!>          Not referenced if RANGE = 'A' or 'V'.
!> \endverbatim
!>
!> \param[out] M
!> \verbatim
!>          M is INTEGER
!>          The total number of eigenvalues found.  0 <= M <= N.
!>          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
!> \endverbatim
!>
!> \param[out] W
!> \verbatim
!>          W is REAL array, dimension (N)
!>          The first M elements contain the selected eigenvalues in
!>          ascending order.
!> \endverbatim
!>
!> \param[out] Z
!> \verbatim
!>          Z is REAL array, dimension (LDZ, max(1,M) )
!>          If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
!>          contain the orthonormal eigenvectors of the matrix T
!>          corresponding to the selected eigenvalues, with the i-th
!>          column of Z holding the eigenvector associated with W(i).
!>          If JOBZ = 'N', then Z is not referenced.
!>          Note: the user must ensure that at least max(1,M) columns are
!>          supplied in the array Z; if RANGE = 'V', the exact value of M
!>          is not known in advance and can be computed with a workspace
!>          query by setting NZC = -1, see below.
!> \endverbatim
!>
!> \param[in] LDZ
!> \verbatim
!>          LDZ is INTEGER
!>          The leading dimension of the array Z.  LDZ >= 1, and if
!>          JOBZ = 'V', then LDZ >= max(1,N).
!> \endverbatim
!>
!> \param[in] NZC
!> \verbatim
!>          NZC is INTEGER
!>          The number of eigenvectors to be held in the array Z.
!>          If RANGE = 'A', then NZC >= max(1,N).
!>          If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].
!>          If RANGE = 'I', then NZC >= IU-IL+1.
!>          If NZC = -1, then a workspace query is assumed; the
!>          routine calculates the number of columns of the array Z that
!>          are needed to hold the eigenvectors.
!>          This value is returned as the first entry of the Z array, and
!>          no error message related to NZC is issued by XERBLA.
!> \endverbatim
!>
!> \param[out] ISUPPZ
!> \verbatim
!>          ISUPPZ is INTEGER array, dimension ( 2*max(1,M) )
!>          The support of the eigenvectors in Z, i.e., the indices
!>          indicating the nonzero elements in Z. The i-th computed eigenvector
!>          is nonzero only in elements ISUPPZ( 2*i-1 ) through
!>          ISUPPZ( 2*i ). This is relevant in the case when the matrix
!>          is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
!> \endverbatim
!>
!> \param[in,out] TRYRAC
!> \verbatim
!>          TRYRAC is LOGICAL
!>          If TRYRAC = .TRUE., indicates that the code should check whether
!>          the tridiagonal matrix defines its eigenvalues to high relative
!>          accuracy.  If so, the code uses relative-accuracy preserving
!>          algorithms that might be (a bit) slower depending on the matrix.
!>          If the matrix does not define its eigenvalues to high relative
!>          accuracy, the code can uses possibly faster algorithms.
!>          If TRYRAC = .FALSE., the code is not required to guarantee
!>          relatively accurate eigenvalues and can use the fastest possible
!>          techniques.
!>          On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix
!>          does not define its eigenvalues to high relative accuracy.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is REAL array, dimension (LWORK)
!>          On exit, if INFO = 0, WORK(1) returns the optimal
!>          (and minimal) LWORK.
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          The dimension of the array WORK. LWORK >= max(1,18*N)
!>          if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!> \endverbatim
!>
!> \param[out] IWORK
!> \verbatim
!>          IWORK is INTEGER array, dimension (LIWORK)
!>          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
!> \endverbatim
!>
!> \param[in] LIWORK
!> \verbatim
!>          LIWORK is INTEGER
!>          The dimension of the array IWORK.  LIWORK >= max(1,10*N)
!>          if the eigenvectors are desired, and LIWORK >= max(1,8*N)
!>          if only the eigenvalues are to be computed.
!>          If LIWORK = -1, then a workspace query is assumed; the
!>          routine only calculates the optimal size of the IWORK array,
!>          returns this value as the first entry of the IWORK array, and
!>          no error message related to LIWORK is issued by XERBLA.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          On exit, INFO
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO = 1X, internal error in SLARRE,
!>                if INFO = 2X, internal error in SLARRV.
!>                Here, the digit X = ABS( IINFO ) < 10, where IINFO is
!>                the nonzero error code returned by SLARRE or
!>                SLARRV, respectively.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date June 2016
!
!> \ingroup realOTHERcomputational
!
!> \par Contributors:
!  ==================
!>
!> Beresford Parlett, University of California, Berkeley, USA \n
!> Jim Demmel, University of California, Berkeley, USA \n
!> Inderjit Dhillon, University of Texas, Austin, USA \n
!> Osni Marques, LBNL/NERSC, USA \n
!> Christof Voemel, University of California, Berkeley, USA
!
!  =====================================================================
      SUBROUTINE SSTEMR(Jobz,Range,N,D,E,Vl,Vu,Il,Iu,M,W,Z,Ldz,Nzc,     &
     &                  Isuppz,Tryrac,Work,Lwork,Iwork,Liwork,Info)
      IMPLICIT NONE
!*--SSTEMR324
!
!  -- LAPACK computational routine (version 3.7.1) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     June 2016
!
!     .. Scalar Arguments ..
      CHARACTER Jobz , Range
      LOGICAL Tryrac
      INTEGER Il , Info , Iu , Ldz , Nzc , Liwork , Lwork , M , N
      REAL Vl , Vu
!     ..
!     .. Array Arguments ..
      INTEGER Isuppz(*) , Iwork(*)
      REAL D(*) , E(*) , W(*) , Work(*)
      REAL Z(Ldz,*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ZERO , ONE , FOUR , MINRGP
      PARAMETER (ZERO=0.0E0,ONE=1.0E0,FOUR=4.0E0,MINRGP=3.0E-3)
!     ..
!     .. Local Scalars ..
      LOGICAL alleig , indeig , lquery , valeig , wantz , zquery
      INTEGER i , ibegin , iend , ifirst , iil , iindbl , iindw ,       &
     &        iindwk , iinfo , iinspl , iiu , ilast , in , indd ,       &
     &        inde2 , inderr , indgp , indgrs , indwrk , itmp , itmp2 , &
     &        j , jblk , jj , liwmin , lwmin , nsplit , nzcmin ,        &
     &        offset , wbegin , wend
      REAL bignum , cs , eps , pivmin , r1 , r2 , rmax , rmin , rtol1 , &
     &     rtol2 , safmin , scale , smlnum , sn , thresh , tmp , tnrm , &
     &     wl , wu
!     ..
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      REAL SLAMCH , SLANST
      EXTERNAL LSAME , SLAMCH , SLANST
!     ..
!     .. External Subroutines ..
      EXTERNAL SCOPY , SLAE2 , SLAEV2 , SLARRC , SLARRE , SLARRJ ,      &
     &         SLARRR , SLARRV , SLASRT , SSCAL , SSWAP , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , MIN , SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      wantz = LSAME(Jobz,'V')
      alleig = LSAME(Range,'A')
      valeig = LSAME(Range,'V')
      indeig = LSAME(Range,'I')
!
      lquery = ((Lwork==-1) .OR. (Liwork==-1))
      zquery = (Nzc==-1)

!     SSTEMR needs WORK of size 6*N, IWORK of size 3*N.
!     In addition, SLARRE needs WORK of size 6*N, IWORK of size 5*N.
!     Furthermore, SLARRV needs WORK of size 12*N, IWORK of size 7*N.
      IF ( wantz ) THEN
         lwmin = 18*N
         liwmin = 10*N
      ELSE
!        need less workspace if only the eigenvalues are wanted
         lwmin = 12*N
         liwmin = 8*N
      ENDIF

      wl = ZERO
      wu = ZERO
      iil = 0
      iiu = 0
      nsplit = 0

      IF ( valeig ) THEN
!        We do not reference VL, VU in the cases RANGE = 'I','A'
!        The interval (WL, WU] contains all the wanted eigenvalues.
!        It is either given by the user or computed in SLARRE.
         wl = Vl
         wu = Vu
      ELSEIF ( indeig ) THEN
!        We do not reference IL, IU in the cases RANGE = 'V','A'
         iil = Il
         iiu = Iu
      ENDIF
!
      Info = 0
      IF ( .NOT.(wantz .OR. LSAME(Jobz,'N')) ) THEN
         Info = -1
      ELSEIF ( .NOT.(alleig .OR. valeig .OR. indeig) ) THEN
         Info = -2
      ELSEIF ( N<0 ) THEN
         Info = -3
      ELSEIF ( valeig .AND. N>0 .AND. wu<=wl ) THEN
         Info = -7
      ELSEIF ( indeig .AND. (iil<1 .OR. iil>N) ) THEN
         Info = -8
      ELSEIF ( indeig .AND. (iiu<iil .OR. iiu>N) ) THEN
         Info = -9
      ELSEIF ( Ldz<1 .OR. (wantz .AND. Ldz<N) ) THEN
         Info = -13
      ELSEIF ( Lwork<lwmin .AND. .NOT.lquery ) THEN
         Info = -17
      ELSEIF ( Liwork<liwmin .AND. .NOT.lquery ) THEN
         Info = -19
      ENDIF
!
!     Get machine constants.
!
      safmin = SLAMCH('Safe minimum')
      eps = SLAMCH('Precision')
      smlnum = safmin/eps
      bignum = ONE/smlnum
      rmin = SQRT(smlnum)
      rmax = MIN(SQRT(bignum),ONE/SQRT(SQRT(safmin)))
!
      IF ( Info==0 ) THEN
         Work(1) = lwmin
         Iwork(1) = liwmin
!
         IF ( wantz .AND. alleig ) THEN
            nzcmin = N
         ELSEIF ( wantz .AND. valeig ) THEN
            CALL SLARRC('T',N,Vl,Vu,D,E,safmin,nzcmin,itmp,itmp2,Info)
         ELSEIF ( wantz .AND. indeig ) THEN
            nzcmin = iiu - iil + 1
         ELSE
!           WANTZ .EQ. FALSE.
            nzcmin = 0
         ENDIF
         IF ( zquery .AND. Info==0 ) THEN
            Z(1,1) = nzcmin
         ELSEIF ( Nzc<nzcmin .AND. .NOT.zquery ) THEN
            Info = -14
         ENDIF
      ENDIF

      IF ( Info/=0 ) THEN
!
         CALL XERBLA('SSTEMR',-Info)
!
         RETURN
      ELSEIF ( lquery .OR. zquery ) THEN
         RETURN
      ENDIF
!
!     Handle N = 0, 1, and 2 cases immediately
!
      M = 0
      IF ( N==0 ) RETURN
!
      IF ( N==1 ) THEN
         IF ( alleig .OR. indeig ) THEN
            M = 1
            W(1) = D(1)
         ELSEIF ( wl<D(1) .AND. wu>=D(1) ) THEN
            M = 1
            W(1) = D(1)
         ENDIF
         IF ( wantz .AND. (.NOT.zquery) ) THEN
            Z(1,1) = ONE
            Isuppz(1) = 1
            Isuppz(2) = 1
         ENDIF
         RETURN
      ENDIF
!
      IF ( N==2 ) THEN
         IF ( .NOT.wantz ) THEN
            CALL SLAE2(D(1),E(1),D(2),r1,r2)
         ELSEIF ( wantz .AND. (.NOT.zquery) ) THEN
            CALL SLAEV2(D(1),E(1),D(2),r1,r2,cs,sn)
         ENDIF
         IF ( alleig .OR. (valeig .AND. (r2>wl) .AND. (r2<=wu)) .OR.    &
     &        (indeig .AND. (iil==1)) ) THEN
            M = M + 1
            W(M) = r2
            IF ( wantz .AND. (.NOT.zquery) ) THEN
               Z(1,M) = -sn
               Z(2,M) = cs
!              Note: At most one of SN and CS can be zero.
               IF ( sn==ZERO ) THEN
                  Isuppz(2*M-1) = 2
                  Isuppz(2*M) = 2
               ELSEIF ( cs/=ZERO ) THEN
                  Isuppz(2*M-1) = 1
                  Isuppz(2*M) = 2
               ELSE
                  Isuppz(2*M-1) = 1
                  Isuppz(2*M) = 1
               ENDIF
            ENDIF
         ENDIF
         IF ( alleig .OR. (valeig .AND. (r1>wl) .AND. (r1<=wu)) .OR.    &
     &        (indeig .AND. (iiu==2)) ) THEN
            M = M + 1
            W(M) = r1
            IF ( wantz .AND. (.NOT.zquery) ) THEN
               Z(1,M) = cs
               Z(2,M) = sn
!              Note: At most one of SN and CS can be zero.
               IF ( sn==ZERO ) THEN
                  Isuppz(2*M-1) = 2
                  Isuppz(2*M) = 2
               ELSEIF ( cs/=ZERO ) THEN
                  Isuppz(2*M-1) = 1
                  Isuppz(2*M) = 2
               ELSE
                  Isuppz(2*M-1) = 1
                  Isuppz(2*M) = 1
               ENDIF
            ENDIF
         ENDIF
      ELSE

!     Continue with general N

         indgrs = 1
         inderr = 2*N + 1
         indgp = 3*N + 1
         indd = 4*N + 1
         inde2 = 5*N + 1
         indwrk = 6*N + 1
!
         iinspl = 1
         iindbl = N + 1
         iindw = 2*N + 1
         iindwk = 3*N + 1
!
!        Scale matrix to allowable range, if necessary.
!        The allowable range is related to the PIVMIN parameter; see the
!        comments in SLARRD.  The preference for scaling small values
!        up is heuristic; we expect users' matrices not to be close to the
!        RMAX threshold.
!
         scale = ONE
         tnrm = SLANST('M',N,D,E)
         IF ( tnrm>ZERO .AND. tnrm<rmin ) THEN
            scale = rmin/tnrm
         ELSEIF ( tnrm>rmax ) THEN
            scale = rmax/tnrm
         ENDIF
         IF ( scale/=ONE ) THEN
            CALL SSCAL(N,scale,D,1)
            CALL SSCAL(N-1,scale,E,1)
            tnrm = tnrm*scale
            IF ( valeig ) THEN
!              If eigenvalues in interval have to be found,
!              scale (WL, WU] accordingly
               wl = wl*scale
               wu = wu*scale
            ENDIF
         ENDIF
!
!        Compute the desired eigenvalues of the tridiagonal after splitting
!        into smaller subblocks if the corresponding off-diagonal elements
!        are small
!        THRESH is the splitting parameter for SLARRE
!        A negative THRESH forces the old splitting criterion based on the
!        size of the off-diagonal. A positive THRESH switches to splitting
!        which preserves relative accuracy.
!
         IF ( Tryrac ) THEN
!           Test whether the matrix warrants the more expensive relative approach.
            CALL SLARRR(N,D,E,iinfo)
         ELSE
!           The user does not care about relative accurately eigenvalues
            iinfo = -1
         ENDIF
!        Set the splitting criterion
         IF ( iinfo==0 ) THEN
            thresh = eps
         ELSE
            thresh = -eps
!           relative accuracy is desired but T does not guarantee it
            Tryrac = .FALSE.
         ENDIF
!
!           Copy original diagonal, needed to guarantee relative accuracy
         IF ( Tryrac ) CALL SCOPY(N,D,1,Work(indd),1)
!        Store the squares of the offdiagonal values of T
         DO j = 1 , N - 1
            Work(inde2+j-1) = E(j)**2
         ENDDO

!        Set the tolerance parameters for bisection
         IF ( .NOT.wantz ) THEN
!           SLARRE computes the eigenvalues to full precision.
            rtol1 = FOUR*eps
            rtol2 = FOUR*eps
         ELSE
!           SLARRE computes the eigenvalues to less than full precision.
!           SLARRV will refine the eigenvalue approximations, and we can
!           need less accurate initial bisection in SLARRE.
!           Note: these settings do only affect the subset case and SLARRE
            rtol1 = MAX(SQRT(eps)*5.0E-2,FOUR*eps)
            rtol2 = MAX(SQRT(eps)*5.0E-3,FOUR*eps)
         ENDIF
         CALL SLARRE(Range,N,wl,wu,iil,iiu,D,E,Work(inde2),rtol1,rtol2, &
     &               thresh,nsplit,Iwork(iinspl),M,W,Work(inderr),      &
     &               Work(indgp),Iwork(iindbl),Iwork(iindw),Work(indgrs)&
     &               ,pivmin,Work(indwrk),Iwork(iindwk),iinfo)
         IF ( iinfo/=0 ) THEN
            Info = 10 + ABS(iinfo)
            RETURN
         ENDIF
!        Note that if RANGE .NE. 'V', SLARRE computes bounds on the desired
!        part of the spectrum. All desired eigenvalues are contained in
!        (WL,WU]

         IF ( wantz ) THEN
!
!           Compute the desired eigenvectors corresponding to the computed
!           eigenvalues
!
            CALL SLARRV(N,wl,wu,D,E,pivmin,Iwork(iinspl),M,1,M,MINRGP,  &
     &                  rtol1,rtol2,W,Work(inderr),Work(indgp),         &
     &                  Iwork(iindbl),Iwork(iindw),Work(indgrs),Z,Ldz,  &
     &                  Isuppz,Work(indwrk),Iwork(iindwk),iinfo)
            IF ( iinfo/=0 ) THEN
               Info = 20 + ABS(iinfo)
               RETURN
            ENDIF
         ELSE
!           SLARRE computes eigenvalues of the (shifted) root representation
!           SLARRV returns the eigenvalues of the unshifted matrix.
!           However, if the eigenvectors are not desired by the user, we need
!           to apply the corresponding shifts from SLARRE to obtain the
!           eigenvalues of the original matrix.
            DO j = 1 , M
               itmp = Iwork(iindbl+j-1)
               W(j) = W(j) + E(Iwork(iinspl+itmp-1))
            ENDDO
         ENDIF
!

         IF ( Tryrac ) THEN
!           Refine computed eigenvalues so that they are relatively accurate
!           with respect to the original matrix T.
            ibegin = 1
            wbegin = 1
            DO jblk = 1 , Iwork(iindbl+M-1)
               iend = Iwork(iinspl+jblk-1)
               in = iend - ibegin + 1
               wend = wbegin - 1
               DO
!              check if any eigenvalues have to be refined in this block
                  IF ( wend<M ) THEN
                     IF ( Iwork(iindbl+wend)==jblk ) THEN
                        wend = wend + 1
                        CYCLE
                     ENDIF
                  ENDIF
                  IF ( wend<wbegin ) THEN
                     ibegin = iend + 1
                     EXIT
                  ENDIF

                  offset = Iwork(iindw+wbegin-1) - 1
                  ifirst = Iwork(iindw+wbegin-1)
                  ilast = Iwork(iindw+wend-1)
                  rtol2 = FOUR*eps
                  CALL SLARRJ(in,Work(indd+ibegin-1),                   &
     &                        Work(inde2+ibegin-1),ifirst,ilast,rtol2,  &
     &                        offset,W(wbegin),Work(inderr+wbegin-1),   &
     &                        Work(indwrk),Iwork(iindwk),pivmin,tnrm,   &
     &                        iinfo)
                  ibegin = iend + 1
                  wbegin = wend + 1
                  EXIT
               ENDDO
            ENDDO
         ENDIF
!
!        If matrix was scaled, then rescale eigenvalues appropriately.
!
         IF ( scale/=ONE ) CALL SSCAL(M,ONE/scale,W,1)
      ENDIF
!
!     If eigenvalues are not in increasing order, then sort them,
!     possibly along with eigenvectors.
!
      IF ( nsplit>1 .OR. N==2 ) THEN
         IF ( .NOT.wantz ) THEN
            CALL SLASRT('I',M,W,iinfo)
            IF ( iinfo/=0 ) THEN
               Info = 3
               RETURN
            ENDIF
         ELSE
            DO j = 1 , M - 1
               i = 0
               tmp = W(j)
               DO jj = j + 1 , M
                  IF ( W(jj)<tmp ) THEN
                     i = jj
                     tmp = W(jj)
                  ENDIF
               ENDDO
               IF ( i/=0 ) THEN
                  W(i) = W(j)
                  W(j) = tmp
                  IF ( wantz ) THEN
                     CALL SSWAP(N,Z(1,i),1,Z(1,j),1)
                     itmp = Isuppz(2*i-1)
                     Isuppz(2*i-1) = Isuppz(2*j-1)
                     Isuppz(2*j-1) = itmp
                     itmp = Isuppz(2*i)
                     Isuppz(2*i) = Isuppz(2*j)
                     Isuppz(2*j) = itmp
                  ENDIF
               ENDIF
            ENDDO
         ENDIF
      ENDIF
!
!
      Work(1) = lwmin
      Iwork(1) = liwmin
!
!     End of SSTEMR
!
      END SUBROUTINE SSTEMR


!===============================
! DEFINING variables
!  except for prm_var
!===============================

module prm_fwd

	use prm_matrix

	!== ESTMPR ==
	real(8) x(kfg,4,50), er(kfg,4,50)
	!== FORWDI ==
	character(len=24), save :: fwdjac(50), hd_jac(50)
	!== FWPRM ==
	integer, save :: isf, ihf, ivf
	real(8), save :: zf(kfo,kmp), yf(kfo), stf(2,kif)
	!== JUSTIN ==
	integer :: ndgs(50), js0(50), jt0(50), jd2(50), just(4,50)
	!== OCOD ==
	real(8), save :: alat0, alng0
	integer, save :: icord
	real(8), save :: xtr(ms), ytr(ms,mt), ztr(ms,mt), da2

	real(8), save :: e_gsi, e_jcg, herr, setalpha

	real(8), parameter :: pi = 3.14159265358979324d0

end module prm_fwd


#include "f_defs.h"

!===============================================================================
!
! Modules:
!
! input_utils_m   Originally By DAS     Last modified by Meng Wu
!
!===============================================================================

module input_utils_m
  use global_m
  use blas_m
  implicit none
  private
  public :: gvec_index, kinetic_energies, calc_efermi
contains

  !---------------------------------------------------------------------------------------------------
  !! Compute index_vec indices relating G-vectors in reduced coordinates to positions in the FFT grid
  subroutine gvec_index(gvec)
    type(gspace), intent(inout) :: gvec
    integer :: ig, iadd

    PUSH_SUB(gvec_index)

    gvec%nFFTgridpts = product(gvec%FFTgrid(1:3))
    SAFE_ALLOCATE(gvec%index_vec, (gvec%nFFTgridpts))
    gvec%index_vec(:) = 0

    do ig = 1, gvec%ng
       !! if a mean-field code does not use the appropriate convention, this could happen.
       if (any(2 * gvec%components(1:3, ig) >= gvec%FFTgrid(1:3) .or. &
            2 * gvec%components(1:3, ig) < -gvec%FFTgrid(1:3))) then
          call die("gvectors must be in the interval [-FFTgrid/2, FFTgrid/2)")
       endif

       iadd = ((gvec%components(1, ig) + gvec%FFTgrid(1) / 2) * gvec%FFTgrid(2) &
            + gvec%components(2, ig) + gvec%FFTgrid(2) / 2) * gvec%FFTgrid(3) &
            + gvec%components(3, ig) + gvec%FFTgrid(3) / 2 + 1

       gvec%index_vec(iadd) = ig
    enddo

    POP_SUB(gvec_index)
    return
  end subroutine gvec_index

  !-----------------------------------------------------------------
  !> This routine calculates the kinetic energies |G+q|^2 or |G|^2 for all
  !! the G-vectors in gvec%components using the reciprocal metric bdot:
  !!   ekin(ig) = \sum_{m,n} G(m,ig) B(m,n) G(n,ig)
  !! We perform the sum by first performing the Cholesky decomposition of B,
  !! B := U^T U. Then, we write V := U G and write ekin = V^T V
  !! Using Cholesky decomposition has the same flop count as using dgemms, but
  !! it`s easier for the compiler to vectorize.
  !!
  !! \param gvec gspace structure that contains all the gvectors gvec%components
  !! \param bdot reciprocal metric
  !! \param ekin array holding the output kinetic energies
  !! \param qvec use this to compute |q+G|^2 instead of |G|^2
  subroutine kinetic_energies(gvec, bdot, ekin, qvec)
    type(gspace), intent(in) :: gvec
    real(DP), intent(in) :: bdot(3, 3)
    real(DP), intent(out) :: ekin(:) !< (gvec%ng)
    real(DP), optional, intent(in) :: qvec(3)

    integer :: ig, info
    real(DP) :: qkv(3,gvec%ng), vmid(3), U(3,3) ! FHJ: stack allocation is faster!

    PUSH_SUB(kinetic_energies)

    if (present(qvec)) then
       do ig = 1,gvec%ng
          qkv(1:3,ig) = qvec(1:3) + DBLE(gvec%components(1:3,ig))
       enddo
    else
       qkv(1:3,1:gvec%ng) = DBLE(gvec%components(1:3,1:gvec%ng))
    endif

    U(1:3, 1:3) = bdot(1:3, 1:3)
    ! Cholesky decomposition of the metric: bdot = U^T U
    call dpotrf('U', 3, U, 3, info)
    do ig = 1, gvec%ng
       vmid(1) = U(1,1)*qkv(1,ig) + U(1,2)*qkv(2,ig) + U(1,3)*qkv(3,ig)
       vmid(2) =                    U(2,2)*qkv(2,ig) + U(2,3)*qkv(3,ig)
       vmid(3) =                                       U(3,3)*qkv(3,ig)
       ekin(ig) = vmid(1)**2 + vmid(2)**2 + vmid(3)**2
    enddo

    POP_SUB(kinetic_energies)
    return
  end subroutine kinetic_energies

  subroutine calc_efermi(kp, efermi, ib_min, ib_max)
    type(kpoints), intent(in) :: kp
    real(DP), intent(out) :: efermi
    integer, intent(in) :: ib_min, ib_max
    integer :: ik, is, ib_vbm, ib_vbm_
    real(DP) :: vbm, cbm
    PUSH_SUB(calc_efermi)

    ib_vbm = MAXVAL(kp%ifmax(:, :))
    ib_vbm_ = MINVAL(kp%ifmax(:, :))
    if (ib_vbm .ge. kp%mnband) then
       call die("calc_efermi: ib_vbm >= total number of bands.", only_root_writes=.true.)
    endif
    if (ib_vbm .ne. ib_vbm_) then
       call die("calc_efermi: Check ifmax.", only_root_writes=.true.)
    endif
    if (ib_min > ib_vbm) then
       write(*,*) ib_min, ib_vbm
       call die("calc_efermi ib_min > ib_vbm.", only_root_writes=.true.)
    endif
    if (ib_max < ib_vbm) then
       call die("calc_efermi ib_max > ib_vbm.", only_root_writes=.true.)
    endif

    !> In units of eV
    vbm = (MAXVAL(kp%el(  ib_vbm, :, :))) * RYD
    cbm = (MINVAL(kp%el(ib_vbm+1, :, :))) * RYD
    efermi = (vbm + cbm) / 2.0D0

    do is = 1, kp%nspin
       do ik = 1, kp%nrk
          if (ANY(kp%el(ib_min:kp%ifmax(ik, is), ik, is) > (efermi / RYD + TOL_Zero))) then
             write(*,*) "ib_min = ", ib_min, " ik = ", ik
             call die("calc_efermi: a valence state has higher energy than emiddle.", only_root_writes=.true.)
          endif

          if (ANY(kp%el(kp%ifmax(ik, is)+1:ib_max, ik, is) < (efermi / RYD - TOL_Zero))) then
             if (peinf%inode .eq. 0) then
                write(*,*) "kp%ifmax(ik, is) = ", kp%ifmax(ik, is), " ib_max = ", ib_max
                write(*,'(10F15.5)') kp%el(kp%ifmax(ik, is)+1:ib_max, ik, is) * RYD
                write(*,*) "efermi = ", efermi
                call die("calc_efermi: a conduction state has lower energy than emiddle.", only_root_writes=.true.)
             endif
          endif
       enddo
    enddo

    if (peinf%inode .eq. 0) then
       write(6,'(1X,A,F12.5,A)') 'VBM energy = ', vbm, " eV"
       write(6,'(1X,A,F12.5,A)') 'CBM energy = ', cbm, " eV"
       write(6,'(1X,A,F12.5,A)') 'Fermi energy = ', efermi, " eV"
    endif

    POP_SUB(calc_efermi)
    return
  end subroutine calc_efermi
end module input_utils_m