      SUBROUTINE QPARMD
C
C     MODULE PARAMD PERFORMS THE FOLLOW OP ON PARAMETERS IN DOUBLE
C     PRECISION
C     (REFERENCE - MODULE PARAMR AND SUBROUTINE QPARMR)
C
C     DMAP
C     PARAMD  / /C,N,OP/ V,N,OUTD/V,N,IND1/V,N,IND2/
C                        V,N,OUTC/V,N,INC1/V,N,INC2/V,N,FLAG $
C
C         OP        COMPUTE
C         --        -------------------------------------------
C      BY DEFAULT   FLAG = 0
C      1  ADD       OUTD = IND1 + IND2
C      2  SUB       OUTD = IND1 - IND2
C      3  MPY       OUTD = IND1 * IND2
C      4  DIV       OUTD = IND1 / IND2 (IF IND2 = 0, FLAG IS SET TO +1)
C      5  NOP       RETURN
C      6  SQRT      OUTD = DSQRT(IND1)
C      7  SIN       OUTD = DSIN(IND1) WHERE IND1 IS IN RADIANS
C      8  COS       OUTD = DCOS(IND1) WHERE IND1 IS IN RADIANS
C      9  ABS       OUTD = DABS(IND1)
C     10  EXP       OUTD = DEXP(IND1)
C     11  TAN       OUTD = DTAN(IND1) WHERE IND1 IS IN RADIANS
C     12  ADDC      OUTC = INC1 + INC2
C     13  SUBC      OUTC = INC1 - INC2
C     14  MPYC      OUTC = INC1 * INC2
C     15  DIVC      OUTC = INC1 / INC2 (IF INC2 = 0, FLAG IS SET TO +1)
C     16  COMPLEX   OUTC = (IND1,IND2)
C     17  CSQRT     OUTC = DCSQRT(INC1)
C     18  NORM      OUTD = DSQRT(OUTC(1)**2 + OUTC(2)**2)
C     19  REAL      IND1 = OUTC(1),  IND2 = OUTC(2)
C     20  POWER     OUTD = IND1**IND2
C     21  CONJ      OUTC = DCONJG(INC1)
C     22  EQ        FLAG =-1 IF IND1 COMPARES WITH IND2
C     23  GT        FLAG =-1 IF IND1 IS GT IND2
C     24  GE        FLAG =-1 IF IND1 IS GE IND2
C     25  LT        FLAG =-1 IF IND1 IS LT IND2
C     26  LE        FLAG =-1 IF IND1 IS LE IND2
C     27  NE        FLAG =-1 IF IND1 IS NE IND2
C     28  LOG       OUTD = DLOG10(IND1)
C     29  LN        OUTD = DLOG(IND1)
C     30  FIX       FLAG = OUTD
C     31  FLOAT     OUTD = FLOAT(FLAG)
C
C     NEW OP CODE ADDED IN THIS NEW VERSION, 12/1988 -
C
C     32  ERR       IF FLAG IS 0, SYSTEM NOGO FLAG IS SET TO ZERO
C                   IF FLAG IS NON-ZERO, JOB TERMINATED IF ANY PREVIOUS
C                      PARAMD (OR PARAMR) CONTAINS NON-FATAL ERROR(S)
C
      LOGICAL          PRT
      INTEGER          OP,OPCODE(50),FLAG,IVPS(1),NAME(2),IL(8),ILX(8),
     1                 NAM(2),BLNK
      REAL             TEMP(2)
      DOUBLE PRECISION OUTD,IND1,IND2,OUTC,INC1,INC2,DENOM,TEMPD
      CHARACTER        UFM*23,UWM*25,UIM*29
      COMMON /XMSSG /  UFM,UWM,UIM
      COMMON /BLANK /  OP(2),OUTD,IND1,IND2,OUTC(2),INC1(2),INC2(2),FLAG
      COMMON /XVPS  /  VPS(1)
      COMMON /ILXXD /  IL1,IL2,IL3,IL4,IL5,IL6,IL7,IL8
      COMMON /SYSTEM/  IBUF,NOUT,NOGO,DUMMY(33),KSYS37
      EQUIVALENCE      (VPS(1),IVPS(1)), (TEMPD,TEMP(1)), (IL,IL1)
      DATA NAME     /  4HQPAR,4HMD  /      ,IFIRST / 15  /
      DATA OPCODE   /  4HADD ,4HSUB ,4HMPY ,4HDIV ,4HNOP ,
     1                 4HSQRT,4HSIN ,4HCOS ,4HABS ,4HEXP ,
     2                 4HTAN ,4HADDC,4HSUBC,4HMPYC,4HDIVC,
     3                 4HCOMP,4HCSQR,4HNORM,4HREAL,4HPOWE,
     4                 4HCONJ,4HEQ  ,4HGT  ,4HGE  ,4HLT  ,
     5                 4HLE  ,4HNE  ,4HLOG ,4HLN  ,4HFIX ,
     6                 4HFLOA,4HERR ,4H    ,4H    ,4H    ,
     7                 4H    ,4H    ,4H    ,4H    ,4H    ,
     8                 4H    ,4H    ,4H    ,4H    ,4H    ,
     9                 4H    ,4H    ,4H    ,4H    ,4H    /
      DATA ILX      /  4H1ST ,4H2ND ,4H3RD ,4H4TH ,4H5TH ,
     1                 4H6TH ,4H7TH ,4H8TH               /
      DATA PARM,NAM /  4HPARM,4H/PAR,3HAMD/,BLNK  /4H    /
C
C     SUPPRESS ALL PARAMETER CHECK MESSAGES IF DIAG 37 IS ON
C
      CALL SSWTCH (37,I)
      PRT = I .EQ. 0
      IF (PRT) NAM(1) = BLNK
      IF (PRT) NAM(2) = BLNK
C
C     COMPUTE VPS INDEXES AND PARAMETER NAMES
C
      DO 2 I = 2,8
      CALL FNDPAR (-I,IL(I))
    2 CONTINUE
      IF (.NOT.PRT) GO TO 4
      CALL PAGE2 (IFIRST)
      IFIRST = 6
      WRITE  (NOUT,3) UIM,OP
    3 FORMAT (A29,' FROM PARAMD MODULE - OP CODE = ',2A4, /5X,
     1        '(ALL PARAMD MESSAGES CAN BE SUPPRESSED BY DIAG 37)')
C
C     BRANCH ON OPERATION CODE
C
    4 IFLAG = FLAG
      FLAG  = 0
      IERR  = 0
C
      DO 5 IOP = 1,32
      IF (OP(1) .EQ. OPCODE(IOP)) GO TO
     1   (  10,  20,  30,  40,  50,  60,  70,  80,  90, 100,
     2     110, 120, 130, 140, 150, 160, 170, 180, 190, 200,
     3     210, 220, 230, 240, 250, 260, 270, 280, 290, 300,
     4     310, 320    ), IOP
    5 CONTINUE
      WRITE  (NOUT,6) OP(1),NAM
    6 FORMAT (22X,'UNRECOGNIZABLE OP CODE = ',A4,' (INPUT ERROR)  ',2A4)
      CALL MESAGE (-7,0,NAME)
C
C *******
C     D.P. REAL NUMBER FUNCTIONS
C *******
C
C     ADD
C
   10 OUTD = IND1 + IND2
      GO TO 600
C
C     SUBTRACT
C
   20 OUTD = IND1 - IND2
      GO TO 600
C
C     MULTIPLY
C
   30 OUTD = IND1*IND2
      GO TO 600
C
C     DIVIDE
C
   40 OUTD = 0.D+0
      IF (IND2 .EQ. 0.D+0) GO TO 45
      OUTD = IND1/IND2
      GO TO 600
   45 WRITE  (NOUT,47) NAM
   47 FORMAT (5X,'ERROR - DIVIDED BY ZERO  ',2A4)
      IERR = 1
      FLAG =+1
      IF (IL8 .LE. 0) GO TO 730
      IVPS(IL8) = FLAG
      I = IL8 - 3
      IF (PRT) WRITE (NOUT,48) IVPS(I),IVPS(I+1),FLAG
   48 FORMAT (22X,2A4,2H =,I10,'   (OUTPUT)')
      GO TO 730
C
C     NOP
C
   50 RETURN
C
C     SQUARE ROOT
C
   60 IF (IND1 .LT. 0.D+0) GO TO 65
      OUTD = DSQRT(IND1)
      GO TO 650
   65 WRITE  (NOUT,67) NAM
   67 FORMAT (5X,'ERROR - OPERATING ON A NEGATIVE NUMBER  ',2A4)
      OUTD = 0.D+0
      IERR = 1
      GO TO 650
C
C     SINE
C
   70 OUTD = DSIN(IND1)
      GO TO 650
C
C     COSINE
C
   80 OUTD = DCOS(IND1)
      GO TO 650
C
C     ABSOLUTE VALUE
C
   90 OUTD = DABS(IND1)
      GO TO 650
C
C     EXPONENTIAL
C
  100 OUTD = DEXP(IND1)
      GO TO 650
C
C     TANGENT
C
  110 OUTD = DTAN(IND1)
      GO TO 650
C
C     NORM
C
  180 OUTD = DSQRT(OUTC(1)**2 + OUTC(2)**2)
      GO TO 690
C
C     POWER
C
  200 OUTD  = IND1**IND2
      GO TO 600
C
C     LOG
C
  280 IF (IND1 .LT. 0.D+0) GO TO 65
      OUTD = DLOG10(IND1)
      GO TO 650
C
C     NATURAL LOG
C
  290 IF (IND1 .LT. 0.D+0) GO TO 65
      OUTD = DLOG(IND1)
      GO TO 650
C
C     FLOAT
C
  310 OUTD = IFLAG
      GO TO 670
C
C     ERR
C
  320 IF (IFLAG.NE.0 .AND. KSYS37.NE.0) GO TO 970
      KSYS37 = 0
      NOGO   = 0
      IF (PRT) WRITE (NOUT,325)
  325 FORMAT (5X,'SYSTEM NOGO FLAG IS RESET TO INTEGER ZERO',/)
      GO TO 990
C
C *******
C     COMPLEX FUNCTIONS
C *******
C
C     ADD COMPLEX
C
  120 OUTC(1) = INC1(1) + INC2(1)
      OUTC(2) = INC1(2) + INC2(2)
      GO TO 730
C
C     SUBTRACT COMPLEX
C
  130 OUTC(1) = INC1(1) - INC2(1)
      OUTC(2) = INC1(2) - INC2(2)
      GO TO 730
C
C     MULTIPLY COMPLEX
C
  140 OUTC(1) = INC1(1)*INC2(1) - INC1(2)*INC2(2)
      OUTC(2) = INC1(1)*INC2(2) + INC1(2)*INC2(1)
      GO TO 730
C
C     DIVIDE COMPLEX
C
  150 DENOM = INC2(1)**2 + INC2(2)**2
      IF (DENOM .EQ. 0.D+0) GO TO 155
      OUTC(1) = (INC1(1)*INC2(1) + INC1(2)*INC2(2))/DENOM
      OUTC(2) = (INC1(2)*INC2(1) - INC1(1)*INC2(2))/DENOM
      GO TO 730
  155 OUTC(1) = 0.D+0
      OUTC(2) = 0.D+0
      GO TO 45
C
C     COMPLEX
C
  160 OUTC(1) = IND1
      OUTC(2) = IND2
      GO TO 710
C
C     COMPLEX SQUARE ROOT
C
  170 OUTC(1) = (INC1(1)**2 + INC1(2)**2)**0.25D0
     1          *DCOS(0.5D0*DATAN2(INC1(2),INC1(1)))
      OUTC(2) = (INC1(1)**2 + INC1(2)**2)**0.25D0
     1          *DSIN(0.5D0*DATAN2(INC1(2),INC1(1)))
      GO TO 760
C
C     CONJUGATE
C
  210 OUTC(1) = INC1(1)
      OUTC(2) =-INC1(2)
      GO TO 760
C
C     REAL
C
  190 IND1 = OUTC(1)
      IND2 = OUTC(2)
      GO TO 770
C
C     EQUAL
C
  220 IF (IND1 .EQ. IND2) FLAG = -1
      GO TO 660
C
C     GREATER THAN
C
  230 IF (IND1 .GT. IND2) FLAG = -1
      GO TO 660
C
C     GREATER THAN OR EQUAL
C
  240 IF (IND1 .GE. IND2) FLAG = -1
      GO TO 660
C
C     LESS THAN
C
  250 IF (IND1 .LT. IND2) FLAG = -1
      GO TO 660
C
C     LESS THAN OR EQUAL
C
  260 IF (IND1 .LE. IND2) FLAG = -1
      GO TO 660
C
C     NOT EQUAL
C
  270 IF (IND1 .NE. IND2) FLAG = -1
      GO TO 660
C
C     FIX
C
  300 FLAG = OUTD
      GO TO 720
C
C ---------------------------------------------------
C
C     INPUT PARAMETER ECHO
C
  600 ASSIGN 620 TO IRTN3
      ASSIGN 800 TO IRTN4
  610 IF (.NOT.PRT) GO TO 615
      I = IL3 - 3
      IF (IL3 .LE. 0) WRITE (NOUT,640) ILX(3),PARM,IND1
      IF (IL3 .GT. 0) WRITE (NOUT,640) IVPS(I),IVPS(I+1),IND1
  615 IF (IL3 .EQ. 0) IERR = 1
      GO TO IRTN3, (620,800)
  620 IF (.NOT.PRT) GO TO 645
      J = IL4 - 3
      IF (IL4 .LE. 0) WRITE (NOUT,640) ILX(4),PARM,IND2
      IF (IL4 .GT. 0) WRITE (NOUT,640) IVPS(J),IVPS(J+1),IND2
  640 FORMAT (22X,2A4,3H = ,D15.8,'  (INPUT)')
  645 IF (IL4 .EQ. 0) IERR = 1
      GO TO IRTN4, (800,880,910)
C
  650 ASSIGN 800 TO IRTN3
      GO TO 610
C
  660 ASSIGN 620 TO IRTN3
      ASSIGN 910 TO IRTN4
      GO TO 610
C
  670 IF (.NOT.PRT) GO TO 685
      I = IL8 - 3
      IF (IL8 .LE. 0) WRITE (NOUT,680) ILX(8),PARM,IFLAG
      IF (IL8 .GT. 0) WRITE (NOUT,680) IVPS(I),IVPS(I+1),IFLAG
  680 FORMAT (22X,2A4,2H =,I10,'   (INPUT)')
  685 IF (IL8 .EQ. 0) IERR = 1
      GO TO 800
C
  690 IF (.NOT.PRT) GO TO 705
      I = IL5 - 3
      IF (IL5 .LE. 0) WRITE (NOUT,700) ILX(5),PARM,OUTC
      IF (IL5 .GT. 0) WRITE (NOUT,700) IVPS(I),IVPS(I+1),OUTC
  700 FORMAT (22X,2A4,4H = (,D15.8,1H,,D15.8,')   (INPUT)')
  705 IF (IL5 .EQ. 0) IERR = 1
      GO TO 800
C
  710 ASSIGN 620 TO IRTN3
      ASSIGN 880 TO IRTN4
      GO TO 610
C
  720 IF (.NOT.PRT) GO TO 725
      I = IL2 - 3
      IF (IL2 .LE. 0) WRITE (NOUT,640) ILX(2),PARM,OUTD
      IF (IL2 .GT. 2) WRITE (NOUT,640) IVPS(I),IVPS(I+1),OUTD
  725 IF (IL2 .EQ. 0) IERR = 1
      GO TO 910
C
  730 ASSIGN 750 TO IRTN6
  740 IF (.NOT.PRT) GO TO 745
      I = IL6 - 3
      IF (IL6 .LE. 0) WRITE (NOUT,700) ILX(6),PARM,INC1
      IF (IL6 .GT. 0) WRITE (NOUT,700) IVPS(I),IVPS(I+1),INC1
      IF (IL6 .EQ. 0) IERR = 1
  745 GO TO IRTN6, (750,880)
  750 IF (.NOT.PRT) GO TO 755
      J = IL7 - 3
      IF (IL7 .LE. 0) WRITE (NOUT,700) ILX(7),PARM,INC2
      IF (IL7 .GT. 0) WRITE (NOUT,700) IVPS(J),IVPS(J+1),INC2
  755 IF (IL7 .EQ. 0) IERR = 1
      GO TO 880
C
  760 ASSIGN 880 TO IRTN6
      GO TO 740
C
  770 IF (.NOT.PRT) GO TO 775
      I = IL5 - 3
      IF (IL5 .LE. 0) WRITE (NOUT,700) ILX(5),PARM,OUTC
      IF (IL5 .GT. 0) WRITE (NOUT,700) IVPS(I),IVPS(I+1),OUTC
  775 IF (IL5 .EQ. 0) IERR = 1
      GO TO 840
C
C     OUTPUT PARAMETER CHECK
C
C     SECOND PARAMETER - OUTD
C
  800 IF (IL2  .GT.  0) GO TO 820
      WRITE  (NOUT,810) ILX(2),NAM
  810 FORMAT (22X,A4,'PARAMETER IS MISSING    (OUTPUT ERROR)  ',2A4)
      IERR = 1
      GO TO 950
  820 IF (IERR .EQ. 0) GO TO 825
      TEMP(1) = VPS(IL2  )
      TEMP(2) = VPS(IL2+1)
      OUTD  = TEMPD
  825 TEMPD = OUTD
      VPS(IL2  ) = TEMP(1)
      VPS(IL2+1) = TEMP(2)
      I = IL2 - 3
      IF (PRT) WRITE (NOUT,830) IVPS(I),IVPS(I+1),OUTD
  830 FORMAT (22X,2A4,3H = ,D15.8,'  (OUTPUT)')
      GO TO 950
C
C     THIRD AND FOURTH PARAMETERS - IND1, IND2
C
  840 IF (IL3 .GT.  0) GO TO 850
      WRITE (NOUT,810) ILX(3),NAM
      IERR = 1
      GO TO 860
  850 IF (IERR .EQ. 0) GO TO 855
      TEMP(1) = VPS(IL3  )
      TEMP(2) = VPS(IL3+1)
      IND1  = TEMPD
  855 TEMPD = IND1
      VPS(IL3  ) = TEMP(1)
      VPS(IL3+1) = TEMP(2)
      I = IL3 - 3
      IF (PRT) WRITE (NOUT,830) IVPS(I),IVPS(I+1),IND1
  860 IF (IL4 .GT.  0) GO TO 870
      WRITE (NOUT,810) ILX(4),NAM
      IERR = 1
      GO TO 950
  870 IF (IERR .EQ. 0) GO TO 875
      TEMP(1) = VPS(IL4  )
      TEMP(2) = VPS(IL4+1)
      IND2  = TEMPD
  875 TEMPD = IND2
      VPS(IL4  ) = TEMP(1)
      VPS(IL4+1) = TEMP(2)
      J = IL4 - 3
      IF (PRT) WRITE (NOUT,830) IVPS(J),IVPS(J+1),IND2
      GO TO 950
C
C     FIFTH PARAMETER - OUTC
C
  880 IF (IL5 .GT.  0) GO TO 890
      WRITE (NOUT,810) ILX(5),NAM
      IERR = 1
      GO TO 950
  890 IF (IERR .EQ. 0) GO TO 895
      TEMP(1) = VPS(IL5  )
      TEMP(2) = VPS(IL5+1)
      OUTC(1) = TEMPD
      TEMP(1) = VPS(IL5+2)
      TEMP(2) = VPS(IL5+3)
      OUTC(2) = TEMPD
  895 TEMPD = OUTC(1)
      VPS(IL5  ) = TEMP(1)
      VPS(IL5+1) = TEMP(2)
      TEMPD = OUTC(2)
      VPS(IL5+2) = TEMP(1)
      VPS(IL5+3) = TEMP(2)
      I = IL5 - 3
      IF (PRT) WRITE (NOUT,900) IVPS(I),IVPS(I+1),OUTC
  900 FORMAT (22X,2A4,4H = (,D15.8,1H,,D15.8,')   (OUTPUT)')
      GO TO 950
C
C     EIGHTH PARAMETER - FLAG
C
  910 IF (IL8 .GT.  0) GO TO 920
      WRITE (NOUT,810) ILX(8),NAM
      IERR = 1
      GO TO 950
  920 IF (IERR .EQ. 0) IVPS(IL8) = FLAG
      I = IL8 - 3
      IF (PRT) WRITE (NOUT,930) IVPS(I),IVPS(I+1),IVPS(IL8)
  930 FORMAT (22X,2A4,2H =,I12,6X,'(OUTPUT)')
C
  950 IF (IERR .EQ.  0) GO TO 990
      WRITE  (NOUT,960) UWM,NAM
  960 FORMAT (A25,' - I/O ERROR, OUTPUT NOT SAVED. OUTPUT DEFAULT ',
     1       'VALUE REMAINS ',2A4,/)
      GO TO 990
  970 WRITE  (NOUT,980) NAM
  980 FORMAT (5X,'JOB TERMINTATED DUE TO PREVIOUS ERROR(S)  ',2A4,/)
      CALL PEXIT
  990 IF (KSYS37 .EQ. 0) KSYS37 = IERR
      RETURN
C
      END


        FUNCTION PR_PR6X ( p01, p02, p03, p04 )
C************************************************************************
C* PR_PR6X                                                              *
C*                                                                      *
C* This function computes PR6X, the maximum precipitation amount for up *
C* to 4 preciptiation values in inches.					*
C*                                                                      *
C* REAL PR_PR6X  ( P01, P02, P03, P04 )					*
C*                                                                      *
C* Input parameters:                                                    *
C*      P01		REAL	First precipitation amount		*
C*	P02 		REAL    Second precipitation amount		*
C*	P03		REAL    Third precipitation amount		*
C*	P04		REAL    Fourth precipitation amount		*
C*                                                                      *
C* Output parameters:                                                   *
C*      PR_PR6X         REAL    Max precip. amount among the 4 values	*
C**                                                                     *
C* Log:                                                                 *
C* A. Hardy/GSC		4/99                                            *
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
C------------------------------------------------------------------------
        PR_PR6X = RMISSD
C
        PR_PR6X =  AMAX1 ( p01, p02, p03, p04 )
C*
        RETURN
        END


program f
! Return the value of the f-function
use statistical
implicit none
real(8) :: x
integer :: m,n
character(len=80) :: arg

if (command_argument_count() /= 3) then
   write(0,'(a)') 'Usage: f [x] [n] [m]'
   stop
endif

call get_command_argument(1,arg) ; read(arg,*) x
call get_command_argument(2,arg) ; read(arg,*) n
call get_command_argument(3,arg) ; read(arg,*) m

write(*,*) f_dist(n,m,x)

end program f


	FUNCTION TRAPZQ(X,Y,N,X1,X2,IERR)

c	Finds area below y(x) from x=X1 to x =X2
c	X1 and X2 are not necessarily values of x(i)
c	but must fulfill X1>=x(1) and X2<=x(n)

c	Starts search for X1 at last point found

c	Array declaration
	real x(n),y(n)
	data i1/1/

	trapzq=0.
	ierr=0.
c	Check for values outside valid range
	if (x1.lt.x(1)) then
		write (6,*) 'TRAPZQ: X1 outside valid range:',x1,x(1)
		ierr=1
		return
c		stop
	endif
	if (x2.gt.x(n)) then
		write (6,*) 'TRAPZQ: X2 outside valid range:',x2,x(n)
		ierr=2
		return
c		stop
	endif

c	Search array from last value of i1
c	Reset i1
	if (x1.lt.x(i1)) i1=1

c	Find first element in array X above X1
	do i=i1,n
	if (x(i).ge.x1) then
		i1=i
c		Find by interpolation values of Y1=y(X1)
		Y1 = ( (x(i1)-x1)*y(i1-1) + (x1-x(i1-1))*y(i1) ) / (x(i1)-x(i1-1))
c		Add area from x(i1-1) to X1
		trapzq=trapzq+(x(i1)-x1)*(Y1+y(i1))/2.
		goto 1
	endif
	enddo

c	Find last element in array X below X2
1	do i=i1,n
	if (x(i).ge.x2) then
		i2=i-1
c		Find by interpolation values of Y2=y(X2)
		Y2 = ( (x(i2+1)-x2)*y(i2) + (x2-x(i2))*y(i2+1) ) / (x(i2+1)-x(i2))
c		Add area from x(i2) to X2
		trapzq=trapzq+(x2-x(i2))*(Y2+y(i2))/2.
		goto 2
	endif
	enddo

c	Compute area from x(i1) to x(i2)
2	do i=i1+1,i2
	trapzq=trapzq+(x(i)-x(i-1))*(y(i)+y(i-1))/2.
	enddo

	return
	end


program P4
  implicit none
  real*4 :: pi,one
  real*8 :: pi8,one8

  one=1.
  one8=1.
  pi=atan(one)*4
  pi8=atan(one8)*4

  print "('pi in single ',f20.18,' and pi in double ',f20.18)", pi,pi8

end program P4


      subroutine gen2jet(r,p,wt2,*)
C---generate two particle phase space and x1,x2 integration
C---p1+p2 --> p3+p4
      implicit none
      include 'constants.f'
      include 'mxdim.f'
      include 'jetcuts.f'
      include 'phasemin.f'
      include 'leptcuts.f'
      include 'part.f'
      include 'x1x2.f'
      include 'first.f'
      include 'energy.f'
      include 'nproc.f'
!--- Modified July 11 by CW to switch between photons and jets appropriately
      integer j,nu
      double precision r(mxdim),p(mxpart,4),zmin,zmax,z
      double precision yave,ydif,xjac,y3,y4,phi,wt0,wt2,
     & ydifmin,ydifmax,yavemin,yavemax,xtsq,pt,xt,ptpar
      parameter(wt0=1d0/16d0/pi)
      save ptpar
!$omp threadprivate(ptpar)

      if (first) then
        first=.false.
c--- for dirgam, hflgam and gamgam, generate using photon pt as cutoff
        if ((nproc.eq.280) .or. (nproc.eq.285)
     &  .or.(nproc.eq.283) .or. (nproc.eq.284)) then
           ptpar=gammpt
           if ((part .eq. 'real').and.(nproc .eq. 285)) ptpar=gammpt2
        else
           call read_jetcuts(ptpar,etajetmin,etajetmax)
        endif
      endif

C    PS = 1/(16 pi) dxt^2 d phi/(2 pi) dyave dystar

      do j=1,mxpart
      do nu=1,4
      p(j,nu)=0d0
      enddo
      enddo

      wt2=0d0

c      xtsqmin=(2d0*ptjetmin/sqrts)**2
c      xjac=1d0-xtsqmin
c      xtsq=xtsqmin+xjac*r(3)

c      zmax=(0.5d0*sqrts/ptjetmin)**2
c      zmin=1d0
c      z=zmin+(zmax-zmin)*r(3)
c      xtsq=1d0/z
c      xjac=xtsq**2*(zmax-zmin)

c      xt=dsqrt(xtsq)
c      pt=0.5d0*sqrts*xt

      if (part .eq. 'real') then
        call genpt(r(3),ptpar,.false.,pt,xjac)
      else
        call genpt(r(3),ptpar,.true.,pt,xjac)
      endif
      xjac=xjac*8d0/sqrts**2
      xt=2d0*pt/sqrts
      xtsq=xt**2

      ydifmax=0.5d0*log((2d0-xtsq+2d0*dsqrt(1d0-xtsq))/xtsq)
      ydifmin=-ydifmax

      ydif=ydifmin+(ydifmax-ydifmin)*r(1)
      xjac=xjac*(ydifmax-ydifmin)

      yavemin=dlog(xt*cosh(ydif))
      yavemax=-yavemin
      yave=yavemin+(yavemax-yavemin)*r(2)
      xjac=xjac*(yavemax-yavemin)

      y3=yave+ydif
      y4=yave-ydif

      phi=2d0*pi*r(4)

      xx(1)=0.5d0*xt*(exp(+y3)+exp(+y4))
      xx(2)=0.5d0*xt*(exp(-y3)+exp(-y4))

      if (xx(1)*xx(2) .gt. 1d0) then
      write(6,*) 'problems with xx(1),xx(2) in gen2',xx(1)*xx(2)
      write(6,*) 'xx(1),xx(2)',xx(1),xx(2)
      return 1
      endif
      if   ((xx(1) .gt. 1d0)
     & .or. (xx(2) .gt. 1d0)
     & .or. (xx(1) .lt. xmin)
     & .or. (xx(2) .lt. xmin)
     & ) then
c      write(6,*) 'problems with xx(1),xx(2) in gen2jet',xx(1),xx(2)
      return 1
      endif

      p(1,4)=-0.5d0*xx(1)*sqrts
      p(1,1)=0d0
      p(1,2)=0d0
      p(1,3)=-0.5d0*xx(1)*sqrts

      p(2,4)=-0.5d0*xx(2)*sqrts
      p(2,1)=0d0
      p(2,2)=0d0
      p(2,3)=+0.5d0*xx(2)*sqrts

      p(3,4)=+pt*cosh(y3)
      p(3,1)=+pt*sin(phi)
      p(3,2)=+pt*cos(phi)
      p(3,3)=+pt*sinh(y3)

      p(4,4)=+pt*cosh(y4)
      p(4,1)=-pt*sin(phi)
      p(4,2)=-pt*cos(phi)
      p(4,3)=+pt*sinh(y4)

      wt2=wt0*xjac
      return

      end


      SUBROUTINE LAMCEN(PAR1,PAR2,CPSI,APSI,APHI,XARB,ZARB,XC,ZC)
      COMMON/C1/D(7),F,FL,REQ,RA,RB,RC,RLORA,PI,FLAG,LABI
      REAL*8 D,PHI1,PHI2,R1,R2,TAN1,TAN2,DK,DC,RP1,RP2
      REAL*8 EPS,E1,E2,TANA,RHO,EA,PHIA,NRAD,DPHI,GEODET
      LOGICAL*4 EFLAG
      CHARACTER*3600 LABI
      REAL*4 LIN1,LIN2
      EQUIVALENCE (DK,D(1)),(DC,D(2))
      DATA EFLAG/.FALSE./
      NRAD(X,Y,DPHI)=X*X/DSQRT(X*X*DCOS(DPHI)*DCOS(DPHI)+Y*Y*DSIN(DPHI)
     &*DSIN(DPHI))
80    PHI1=DBLE(PAR1)*DBLE(PI)/1.8D2
C     CHANGE YOUR LATITUDES TO GEODETIC FROM GEOCENTRIC
      PHI1=DABS(GEODET(PHI1))
      PHI2=DBLE(PAR2)*DBLE(PI)/1.8D2
      PHI2=DABS(GEODET(PHI2))
      CAS=SIGN(1.,PAR1)
      R1=NRAD(REQ,FL,PHI1)*DCOS(PHI1)
      R2=NRAD(REQ,FL,PHI2)*DCOS(PHI2)
      EPS=DSQRT(1.D0-FL*FL/REQ/REQ)
      E1=((1.D0+EPS*DSIN(PHI1))/(1.D0-EPS*DSIN(PHI1)))**(EPS/2.D0)
      TAN1=DTAN(PI/4.D0-PHI1/2.D0)*E1
      E2=((1.D0+EPS*DSIN(PHI2))/(1.D0-EPS*DSIN(PHI2)))**(EPS/2.D0)
      TAN2=DTAN(PI/4.D0-PHI2/2.D0)*E2
      DK=DLOG(R1/R2)/DLOG(TAN1/TAN2)
      IF(EFLAG)GO TO 81
      EFLAG=.TRUE.
      DC=R1/(DBLE(F)*DK*TAN1**DK)
      PHIA=DBLE(APHI)*DBLE(PI)/1.8D2
      PHIA=GEODET(PHIA)
      PHIA=PHIA*CAS
1000  EA=((1.D0+EPS*DSIN(PHIA))/(1.D0-EPS*DSIN(PHIA)))**(EPS/2.D0)
      TANA=DTAN(PI/4.D0-PHIA/2.D0)*EA
      RHO=DC*TANA**DK
C     FIND DLAM SO THAT -180.)DLAM)+180.
      DLAM=APSI-CPSI
      DLAM=AMOD(720.+DLAM,360.)
      IF(DLAM.GT.180.)DLAM=DLAM-360.
      DLAM=DLAM*PI/180.
      XC=XARB+RHO*DSIN(DK*DLAM)
      IF(XC.EQ.0.)GO TO 1200
      I=XC+SIGN(.5,XC)
      XC=I
1200  ZC=ZARB-CAS*RHO*DCOS(DK*DLAM)
      IF(ZC.EQ.0.)RETURN
      I=ZC+SIGN(.5,ZC)
      ZC=I
      RETURN
      ENTRY GETCK(PAR1,PAR2,LIN1,LIN2,ZPOL,NCASE)

C     NCASE DETERMINES WAY TO CALCULATE DC AND DK CONSTANTS FOR
C     TWO-STANDARD OTHOMORPHIC CONIC (LAMBERT CONFORMAL) PROJECTION
C     FOR NCASE=...      PARAMETERS GIVEN..  CONTROL PASSES TO...
C     1,2                F,CPHI              70
C     3,6                F,LIN1              10
C     4,7                F,LIN2              20
C     5,8                F,ZPOL              30
C     9                  LIN1,LIN2           40
C     10                 LIN1,ZPOL           50
C     11                 LIN2,ZPOL           60

C     PARAMETERS IN THIS SUBROUTINE ARE AS FOLLOWS...
C     PARI=LATITUDE OF PARALLEL I,I=1,2
C     LINI=PIXEL LINE LOCATION OF PARALLELI IN OUTPUT PIX,I=1,2
C     ZPOL=LINE VALUE OF POLE IN OUTPUT PIX
C     PHII=PARI IN RADIANS,I=1,2
C     RI=RADIUS OF PARI IN KM,I=1,2
C     TANI=TAN((90.-PARI)/2),I=1,2
C     DK=CONSTANT K FOR CONE...SEE SUPERMAP WRITE-UP...
C     DC=CONSTANT C FOR CONE
C     NOTE...DK DEPENDS ONLY ON PAR1 AND PAR2
C      BUT DC DEPENDS ON F.
C      LIN1,LIN2,AND ZPOL DEPEND ON DC AND F.IF ONE OF THE THREE IS
C      SPECIFIED,THE OTHERS CAN BE FOUND

C     NOTE...DK CAN ALWAYS BE CALCULATED AS FOLLOWS...

      IF(EFLAG)GO TO 81
      EFLAG=.TRUE.
      GO TO 80
81    GO TO (70,70,10,20,30,10,20,30,40,50,60), NCASE

C     IN THIS CASE, F (KM/PXL) IS SPECIFIED.TO FIND DC, WE NEED
C      RADIUS OF PAR1 IN PIXELS. WE CAN CALCULATE IT IN KM, THEREBY
C      GETTING RESULT BY USING F...

   10 DC=R1/(DBLE(F)*DK*TAN1**DK)
      RP1=R1/(DBLE(F)*DK)
      ZPOL=LIN1-CAS*SNGL(RP1)
      RP2=DC*TAN2**DK
      LIN2=ZPOL+CAS*SNGL(RP2)
      GO TO 100

C     IN THIS CASE,F AND LIN2 ARE SPECIFIED.
C     CALCULATE DC THE SAME AS ABOVE,THEN LIN1,ZPOL

   20 DC=R2/(DBLE(F)*DK*TAN2**DK)
      RP2=R2/(DBLE(F)*DK)
      ZPOL=LIN2-CAS*SNGL(RP2)
      RP1=DC*TAN1**DK
      LIN1=ZPOL+CAS*SNGL(RP1)
      GO TO 100

C     IN THIS CASE, F AND ZPOL ARE SPECIFIED. WE CAN AGAIN CALCULATE
C      DC FROM F, THEN LIN1,LIN2

   30 DC=R1/(DBLE(F)*DK*TAN1**DK)
      RP1=R1/(DBLE(F)*DK)
      RP2=DC*TAN2**DK
      LIN1=ZPOL+CAS*SNGL(RP1)
      LIN2=ZPOL+CAS*SNGL(RP2)
      GO TO 100

C     HERE,WE ARE GIVEN LIN1 AND LIN2.
C     CALCULATE DC FROM EQUATION...ABS(LIN1-LIN2)=RP2-RP1
C                                                =DC*(TAN1**DK-TAN2**DK)

   40 DC=DABS(DBLE(LIN2-LIN1)/(TAN2**DK-TAN1**DK))
      RP1=DC*TAN1**DK
      RP2=DC*TAN2**DK

C     R1 IS IN KM AT THIS POINT

      F=SNGL(R1/RP1*DK)
      ZPOL=LIN1-CAS*SNGL(RP1)
      GO TO 100

C     HERE,WE ARE GIVEN LIN1 AND ZPOL
C     RP1 IS THEREFORE IMMEDIATE

   50 RP1=DBLE(ABS(LIN1-ZPOL))
      DC=RP1/TAN1**DK
      RP2=DC*TAN2**DK
      LIN2=ZPOL+CAS*SNGL(RP2)
      F=SNGL(R1/RP1*DK)
      GO TO 100

C     HERE,LIN2 AND ZPOL ARE SPECIFIED...ANALOGOUS TO ABOVE

   60 RP2=DBLE(ABS(LIN2-ZPOL))
      DC=RP2/TAN2**DK
      LIN1=CAS*SNGL(RP1)+ZPOL
      F=SNGL(R2/RP2*DK)
      GO TO 100
C     THE FOLLOWING CODE IS THE OLD CRUDE CENTERING TECHNIQUE USED WHEN
C     NONE OF LIN1,LIN2,AND LINE WERE SPECIFIED
C     IT WILL BE EXECUTED NOW ONLY IF RECENTERING WAS ALSO UNSPECIFIED
   70 DC=R1/(DBLE(F)*DK*TAN1**DK)
      LIN1=LIN1*PI/180.
      LIN1=GEODET(DBLE(LIN1))
      LIN1=LIN1*CAS
      EA=((1.D0+EPS*SIN(LIN1))/(1.D0-EPS*SIN(LIN1)))**(EPS/2.D0)
      LIN2=TAN(PI/4.-LIN1/2.)*EA
      ZPOL=ZPOL-CAS*SNGL(DC)*LIN2**SNGL(DK)
      RP1=R1/(DBLE(F)*DK)
      RP2=DC*TAN2**DK
      LIN2=ZPOL+CAS*SNGL(RP2)
      LIN1=ZPOL+CAS*SNGL(RP1)
  100 CONTINUE
      RETURN
      END

c *********************************************************************
      SUBROUTINE VECTOR
      REAL R(3),RMAG,LAT,LONG
      REAL A(3),B(3),C(3)
      REAL D(3,3),E(3,3),F(3,3)
      ENTRY      SPHREC(R,RMAG,LAT,LONG)
C  CONVERT SPHERCAL COORDINATES TO RECTANGULAR VECTOR
      R(1)=RMAG*COS(LAT)*COS(LONG)
      R(2)=RMAG*COS(LAT)*SIN(LONG)
      R(3)=RMAG*SIN(LAT)
      RETURN
      ENTRY      RECSPH(R,RMAG,LAT,LONG)
C  CONVERT KECTANGULAR VECTOR COMPONENTS T SPHERICAL
      RMAG=SQRT(R(1)*R(1)+R(2)*R(2)+R(3)*R(3))
      LAT=ATAN2(R(3),SQRT(R(1)**2+R(2)**2))
      LONG=ATAN2(R(2),R(1))
      RETURN
      ENTRY      UNIT(R)
C  MAKE R A UNIT VECTOR IN SMAE DIRECTION
      X=SQRT(R(1)*R(1)+R(2)*R(2)+R(3)*R(3))
      DO 10 J=1,3
10    R(J)=R(J)/X
      RETURN
      ENTRY      CROSS(A,B,C)
C  VECTOR CROSS PRODUCT C=A X B
      C(1)=A(2)*B(3)-A(3)*B(2)
      C(2)=A(3)*B(1)-A(1)*B(3)
      C(3)=A(1)*B(2)-A(2)*B(1)
      RETURN
      ENTRY MMUL(D,E,F)
C  3 X 3 MATRIX PRODUCT F=D*E
      DO 20 I=1,3
      DO 15 J=1,3
      S=0.
      DO 12 K=1,3
12    S=S+D(I,K)*E(K,J)
      F(I,J)=S
15    CONTINUE
20    CONTINUE
      RETURN
      ENTRY VMUL(A,D,R)
C        VECTOR (3 X 1)=MATRIX (3 X 3) * VECTOR (3 X 1)  R=D*A
      DO 50 I=1,3
      S=0.
      DO 40 J=1,3
40    S=S+D(I,J)*A(J)
50    R(I)=S
      RETURN

      ENTRY mTRANS(D,E)
C        TRANSPOSE 3 X 3 MATRIX  E=TRANSPOSE(D)
      DO 60 I=1,3
      DO 60 J=1,3
   60 E(J,I)=D(I,J)
      RETURN
      END

c ***************************************************************
      REAL*8 FUNCTION GEODET(PHI)
      REAL*8 PHI,PI/3.141592653589793/,D,APHI,GEOCEN
      COMMON/C1/D(7),F,FL,REQ,RA,RB,RC,RLORA,PIE,FLAG,LABI
      CHARACTER*3600 LABI

C     GIVEN GEOCENTRIC LATITUDE PHI IN RADIANS
C     COMPUTE GEODETIC LATITUDE IN RADIANS

      IF(DABS(PHI).GT.PI/2.D0-1.D-6)GO TO 1
      IF(PHI.EQ.0.D0)GO TO 1
      APHI=PI/2.D0-DABS(DATAN(-FL*FL/REQ/REQ/DTAN(PHI)))
      GEODET=APHI
      IF(PHI.LT.0.D0)GEODET=-APHI
      RETURN
1     GEODET=PHI
      RETURN

C     GIVEN GEODETIC LATITUDE PHI IN RADIANS
C     COMPUTE GEOCENTRIC LATITUDE

      ENTRY GEOCEN(PHI)
      IF(DABS(PHI).GT.PI/2.D0-1.D-6)GO TO 2
      APHI=DABS(PHI)
      APHI=DATAN(-FL*FL/REQ/REQ/DTAN(APHI-PI/2.D0))
      GEOCEN=APHI
      IF(PHI.LT.0.D0)GEOCEN=-APHI
      RETURN
2     GEOCEN=PHI
      RETURN
      END


#include "../defines.inc"
!-----------------------------------------------------------------
!
!        Addapted from MC_int.f95
!        By Quinn MacPherson in summer 2016
!
!---------------------------------------------------------------
subroutine interp(wlc_p, RBin, IX, IY, IZ, WX, WY, WZ)
!This program linearly interpolates a bead at RBin into
!8 bins indexed by IX, IY, IZ with weights WX, WY, WZ.
!Interpolation is based on Pike (2009), "Theoretically informed
!coarse grain simulation of polymeric systems".
!
!For exampe a if a bead is closer to the center of IX(1) then IX(2)
!then WX(1) will be proportionally higher then WX(2).  The total
!weight in any of the eight bins is given by WX*WY*WZ.

   use params, only: dp, wlcsim_params
   implicit none
   Type(wlcsim_params), intent(in) :: wlc_p      ! system varibles

   real(dp), intent(inout) :: RBin(3) ! position of bead
   integer, intent(out) :: IX(2)  ! Range of bins in x direction
   integer, intent(out) :: IY(2) ! Range of bins in y direction
   integer, intent(out) :: IZ(2)  ! Range of bins in z direction
   real(dp), intent(out) :: WX(2) ! Fractional contributions in x
   real(dp), intent(out) :: WY(2) ! Fractional contributions in y
   real(dp), intent(out) :: WZ(2) ! Fractional contributions in z
   SELECT CASE (WLC_P__CONFINETYPE)
   CASE ('none') ! Box from 0-wlc_p%LBOX, Bins split by boundaries
      ! Periodic BC
      RBin(1) = MODULO(RBin(1), WLC_P__LBOX_X)
      RBin(2) = MODULO(RBin(2), WLC_P__LBOX_Y)
      RBin(3) = MODULO(RBin(3), WLC_P__LBOX_Z)

      ! Binning
      IX(1) = ceiling(RBin(1)/WLC_P__DBIN)
      IY(1) = ceiling(RBin(2)/WLC_P__DBIN)
      IZ(1) = ceiling(RBin(3)/WLC_P__DBIN)

      IX(2) = IX(1) - 1
      IY(2) = IY(1) - 1
      IZ(2) = IZ(1) - 1

      ! Calculate the bin weighting
      WX(2) = (WLC_P__DBIN*IX(1) - RBin(1))/WLC_P__DBIN
      WX(1) = 1.0_dp - WX(2)
      WY(2) = (WLC_P__DBIN*IY(1) - RBin(2))/WLC_P__DBIN
      WY(1) = 1.0_dp - WY(2)
      WZ(2) = (WLC_P__DBIN*IZ(1) - RBin(3))/WLC_P__DBIN
      WZ(1) = 1.0_dp - WZ(2)

      ! Periodic BC on Bins:
      IX(1) = MODULO(IX(1) - 1, WLC_P__NBIN_X) + 1
      IX(2) = MODULO(IX(2) - 1, WLC_P__NBIN_X) + 1
      IY(1) = MODULO(IY(1) - 1, WLC_P__NBIN_Y) + 1
      IY(2) = MODULO(IY(2) - 1, WLC_P__NBIN_Y) + 1
      IZ(1) = MODULO(IZ(1) - 1, WLC_P__NBIN_Z) + 1
      IZ(2) = MODULO(IZ(2) - 1, WLC_P__NBIN_Z) + 1
   CASE ('platesInZperiodicXY')
      ! Periodic BC
      RBin(1) = MODULO(RBin(1), WLC_P__LBOX_X)
      RBin(2) = MODULO(RBin(2), WLC_P__LBOX_Y)

      ! Binning
      IX(1) = ceiling(RBin(1)/WLC_P__DBIN)
      IY(1) = ceiling(RBin(2)/WLC_P__DBIN)

      IX(2) = IX(1) - 1
      IY(2) = IY(1) - 1

      ! Calculate the bin weighting
      WX(2) = (WLC_P__DBIN*IX(1) - RBin(1))/WLC_P__DBIN   ! WX(2) = (RBin(1)-IX(1)*WLC_P__DBIN)/(IX(2)*WLC_P__DBIN-IX(1)*WLC_P__DBIN)
      WX(1) = 1.0_dp - WX(2)              ! WX(1) = (IX(2)*WLC_P__DBIN-RBin(1))/(IX(2)*WLC_P__DBIN-IX(1)*WLC_P__DBIN)
      WY(2) = (WLC_P__DBIN*IY(1) - RBin(2))/WLC_P__DBIN   ! WY(2) = (RBin(2)-IY(1)*WLC_P__DBIN)/(IY(2)*WLC_P__DBIN-IY(1)*WLC_P__DBIN)
      WY(1) = 1.0_dp - WY(2)              ! WY(1) = (IY(2)*WLC_P__DBIN-RBin(2))/(IY(2)*WLC_P__DBIN-IY(1)*WLC_P__DBIN)

      ! Periodic BC on Bins:
      IX(1) = MODULO(IX(1) - 1, WLC_P__NBIN_X) + 1
      IX(2) = MODULO(IX(2) - 1, WLC_P__NBIN_X) + 1
      IY(1) = MODULO(IY(1) - 1, WLC_P__NBIN_Y) + 1
      IY(2) = MODULO(IY(2) - 1, WLC_P__NBIN_Y) + 1

      if (WLC_P__BOUNDARY_TYPE == "ExtendBinsPast") then
         IZ(1) = nint(RBin(3)/WLC_P__DBIN) + 1 ! Note 1.0 so that box centers are on half intigers
         IZ(2) = IZ(1) - 1
         WZ(2) = (WLC_P__DBIN*IZ(1) - 0.5_dp*WLC_P__DBIN - RBin(3))/WLC_P__DBIN
         WZ(1) = 1.0_dp - WZ(2)
      elseif (WLC_P__BOUNDARY_TYPE == "SolidEdgeBin") then
         if (RBin(3) <= WLC_P__DBIN*0.5_dp) then
            IZ(1) = 2
            IZ(2) = 1
            WZ(1) = 0.0_dp
            WZ(2) = 1.0_dp
         elseif (RBin(3) >= WLC_P__LBOX_Z - WLC_P__DBIN*0.5_dp) then
            IZ(2) = WLC_P__NBIN_Z - 1
            IZ(1) = WLC_P__NBIN_Z
            WZ(1) = 1.0_dp
            WZ(2) = 0.0_dp
         else
            IZ(1) = nint(RBin(3)/WLC_P__DBIN) + 1
            IZ(2) = IZ(1) - 1
            WZ(2) = (WLC_P__DBIN*IZ(1) - 0.5_dp*WLC_P__DBIN - RBin(3))/WLC_P__DBIN
            WZ(1) = 1.0_dp - WZ(2)
         endif
      endif
   CASE ('cube') ! Box confinement
      if (WLC_P__BOUNDARY_TYPE == "ExtendBinsPast") then
         ! Binning
         IX(1) = nint(RBin(1)/WLC_P__DBIN) + 1
         IY(1) = nint(RBin(2)/WLC_P__DBIN) + 1
         IZ(1) = nint(RBin(3)/WLC_P__DBIN) + 1 ! Note +1 because fortran starts a 1

         IX(2) = IX(1) - 1
         IY(2) = IY(1) - 1
         IZ(2) = IZ(1) - 1

         ! Calculate the bin weighting
         WX(2) = (WLC_P__DBIN*IX(1) - 0.5_dp*WLC_P__DBIN - RBin(1))/WLC_P__DBIN
         WX(1) = 1.0_dp - WX(2)
         WY(2) = (WLC_P__DBIN*IY(1) - 0.5_dp*WLC_P__DBIN - RBin(2))/WLC_P__DBIN
         WY(1) = 1.0_dp - WY(2)
         WZ(2) = (WLC_P__DBIN*IZ(1) - 0.5_dp*WLC_P__DBIN - RBin(3))/WLC_P__DBIN
         WZ(1) = 1.0_dp - WZ(2)
      elseif (WLC_P__BOUNDARY_TYPE == "SolidEdgeBin") then
         if (RBin(1) <= WLC_P__DBIN*0.5_dp) then
            IX(1) = 2
            IX(2) = 1
            WX(1) = 0.0_dp
            WX(2) = 1.0_dp
         elseif (RBin(1) >= WLC_P__LBOX_X - WLC_P__DBIN*0.5_dp) then
            IX(2) = WLC_P__NBIN_X - 1
            IX(1) = WLC_P__NBIN_X
            WX(1) = 1.0_dp
            WX(2) = 0.0_dp
         else
            IX(1) = nint(RBin(1)/WLC_P__DBIN) + 1
            IX(2) = IX(1) - 1
            WX(2) = (WLC_P__DBIN*IX(1) - 0.5_dp*WLC_P__DBIN - RBin(1))/WLC_P__DBIN
            WX(1) = 1.0_dp - WX(2)
         endif
         !  -----
         if (RBin(2) <= WLC_P__DBIN*0.5_dp) then
            IY(1) = 2
            IY(2) = 1
            WY(1) = 0.0_dp
            WY(2) = 1.0_dp
         elseif (RBin(2) >= WLC_P__LBOX_Y - WLC_P__DBIN*0.5_dp) then
            IY(2) = WLC_P__NBIN_Y - 1
            IY(1) = WLC_P__NBIN_Y
            WY(1) = 1.0_dp
            WY(2) = 0.0_dp
         else
            IY(1) = nint(RBin(2)/WLC_P__DBIN) + 1
            IY(2) = IY(1) - 1
            WY(2) = (WLC_P__DBIN*IY(1) - 0.5_dp*WLC_P__DBIN - RBin(2))/WLC_P__DBIN
            WY(1) = 1.0_dp - WY(2)
         endif
         !  -----
         if (RBin(3) <= WLC_P__DBIN*0.5_dp) then
            IZ(1) = 2
            IZ(2) = 1
            WZ(1) = 0.0_dp
            WZ(2) = 1.0_dp
         elseif (RBin(3) >= WLC_P__LBOX_Z - WLC_P__DBIN*0.5_dp) then
            IZ(2) = WLC_P__NBIN_Z - 1
            IZ(1) = WLC_P__NBIN_Z
            WZ(1) = 1.0_dp
            WZ(2) = 0.0_dp
         else
            IZ(1) = nint(RBin(3)/WLC_P__DBIN) + 1
            IZ(2) = IZ(1) - 1
            WZ(2) = (WLC_P__DBIN*IZ(1) - 0.5_dp*WLC_P__DBIN - RBin(3))/WLC_P__DBIN
            WZ(1) = 1.0_dp - WZ(2)
         endif
      endif
   CASE ('sphere')
      ! Binning
      IX(1) = nint(RBin(1)/WLC_P__DBIN) + 1
      IY(1) = nint(RBin(2)/WLC_P__DBIN) + 1
      IZ(1) = nint(RBin(3)/WLC_P__DBIN) + 1 ! Note +1 because fortran starts a 1

      IX(2) = IX(1) - 1
      IY(2) = IY(1) - 1
      IZ(2) = IZ(1) - 1

      ! Calculate the bin weighting
      WX(2) = (WLC_P__DBIN*IX(1) - 0.5_dp*WLC_P__DBIN - RBin(1))/WLC_P__DBIN
      WX(1) = 1.0_dp - WX(2)
      WY(2) = (WLC_P__DBIN*IY(1) - 0.5_dp*WLC_P__DBIN - RBin(2))/WLC_P__DBIN
      WY(1) = 1.0_dp - WY(2)
      WZ(2) = (WLC_P__DBIN*IZ(1) - 0.5_dp*WLC_P__DBIN - RBin(3))/WLC_P__DBIN
      WZ(1) = 1.0_dp - WZ(2)
   CASE ('periodicUnequal') ! Box from 0-wlc_p%LBOX, Bins split by boundaries
      print *, "CONFINETYPE = periodicUnequal has be depreciated"
      print *, "Please use 'none'"
      stop 1
   END SELECT
   return
end subroutine


      SUBROUTINE SLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS,
     $                   WORK, IWORK, INFO )
*
*  -- LAPACK routine (version 3.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            ICOMPQ, INFO, LDQ, LDQS, N, QSIZ
*     ..
*     .. Array Arguments ..
      INTEGER            IWORK( * )
      REAL               D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ),
     $                   WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  SLAED0 computes all eigenvalues and corresponding eigenvectors of a
*  symmetric tridiagonal matrix using the divide and conquer method.
*
*  Arguments
*  =========
*
*  ICOMPQ  (input) INTEGER
*          = 0:  Compute eigenvalues only.
*          = 1:  Compute eigenvectors of original dense symmetric matrix
*                also.  On entry, Q contains the orthogonal matrix used
*                to reduce the original matrix to tridiagonal form.
*          = 2:  Compute eigenvalues and eigenvectors of tridiagonal
*                matrix.
*
*  QSIZ   (input) INTEGER
*         The dimension of the orthogonal matrix used to reduce
*         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.
*
*  N      (input) INTEGER
*         The dimension of the symmetric tridiagonal matrix.  N >= 0.
*
*  D      (input/output) REAL array, dimension (N)
*         On entry, the main diagonal of the tridiagonal matrix.
*         On exit, its eigenvalues.
*
*  E      (input) REAL array, dimension (N-1)
*         The off-diagonal elements of the tridiagonal matrix.
*         On exit, E has been destroyed.
*
*  Q      (input/output) REAL array, dimension (LDQ, N)
*         On entry, Q must contain an N-by-N orthogonal matrix.
*         If ICOMPQ = 0    Q is not referenced.
*         If ICOMPQ = 1    On entry, Q is a subset of the columns of the
*                          orthogonal matrix used to reduce the full
*                          matrix to tridiagonal form corresponding to
*                          the subset of the full matrix which is being
*                          decomposed at this time.
*         If ICOMPQ = 2    On entry, Q will be the identity matrix.
*                          On exit, Q contains the eigenvectors of the
*                          tridiagonal matrix.
*
*  LDQ    (input) INTEGER
*         The leading dimension of the array Q.  If eigenvectors are
*         desired, then  LDQ >= max(1,N).  In any case,  LDQ >= 1.
*
*  QSTORE (workspace) REAL array, dimension (LDQS, N)
*         Referenced only when ICOMPQ = 1.  Used to store parts of
*         the eigenvector matrix when the updating matrix multiplies
*         take place.
*
*  LDQS   (input) INTEGER
*         The leading dimension of the array QSTORE.  If ICOMPQ = 1,
*         then  LDQS >= max(1,N).  In any case,  LDQS >= 1.
*
*  WORK   (workspace) REAL array,
*         If ICOMPQ = 0 or 1, the dimension of WORK must be at least
*                     1 + 3*N + 2*N*lg N + 2*N**2
*                     ( lg( N ) = smallest integer k
*                                 such that 2^k >= N )
*         If ICOMPQ = 2, the dimension of WORK must be at least
*                     4*N + N**2.
*
*  IWORK  (workspace) INTEGER array,
*         If ICOMPQ = 0 or 1, the dimension of IWORK must be at least
*                        6 + 6*N + 5*N*lg N.
*                        ( lg( N ) = smallest integer k
*                                    such that 2^k >= N )
*         If ICOMPQ = 2, the dimension of IWORK must be at least
*                        3 + 5*N.
*
*  INFO   (output) INTEGER
*          = 0:  successful exit.
*          < 0:  if INFO = -i, the i-th argument had an illegal value.
*          > 0:  The algorithm failed to compute an eigenvalue while
*                working on the submatrix lying in rows and columns
*                INFO/(N+1) through mod(INFO,N+1).
*
*  Further Details
*  ===============
*
*  Based on contributions by
*     Jeff Rutter, Computer Science Division, University of California
*     at Berkeley, USA
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.E0, ONE = 1.E0, TWO = 2.E0 )
*     ..
*     .. Local Scalars ..
      INTEGER            CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM,
     $                   IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM,
     $                   J, K, LGN, MATSIZ, MSD2, SMLSIZ, SMM1, SPM1,
     $                   SPM2, SUBMAT, SUBPBS, TLVLS
      REAL               TEMP
*     ..
*     .. External Subroutines ..
      EXTERNAL           SCOPY, SGEMM, SLACPY, SLAED1, SLAED7, SSTEQR,
     $                   XERBLA
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, INT, LOG, MAX, REAL
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
*
      IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.2 ) THEN
         INFO = -1
      ELSE IF( ( ICOMPQ.EQ.1 ) .AND. ( QSIZ.LT.MAX( 0, N ) ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDQS.LT.MAX( 1, N ) ) THEN
         INFO = -9
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SLAED0', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
      SMLSIZ = ILAENV( 9, 'SLAED0', ' ', 0, 0, 0, 0 )
*
*     Determine the size and placement of the submatrices, and save in
*     the leading elements of IWORK.
*
      IWORK( 1 ) = N
      SUBPBS = 1
      TLVLS = 0
   10 CONTINUE
      IF( IWORK( SUBPBS ).GT.SMLSIZ ) THEN
         DO 20 J = SUBPBS, 1, -1
            IWORK( 2*J ) = ( IWORK( J )+1 ) / 2
            IWORK( 2*J-1 ) = IWORK( J ) / 2
   20    CONTINUE
         TLVLS = TLVLS + 1
         SUBPBS = 2*SUBPBS
         GO TO 10
      END IF
      DO 30 J = 2, SUBPBS
         IWORK( J ) = IWORK( J ) + IWORK( J-1 )
   30 CONTINUE
*
*     Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1
*     using rank-1 modifications (cuts).
*
      SPM1 = SUBPBS - 1
      DO 40 I = 1, SPM1
         SUBMAT = IWORK( I ) + 1
         SMM1 = SUBMAT - 1
         D( SMM1 ) = D( SMM1 ) - ABS( E( SMM1 ) )
         D( SUBMAT ) = D( SUBMAT ) - ABS( E( SMM1 ) )
   40 CONTINUE
*
      INDXQ = 4*N + 3
      IF( ICOMPQ.NE.2 ) THEN
*
*        Set up workspaces for eigenvalues only/accumulate new vectors
*        routine
*
         TEMP = LOG( REAL( N ) ) / LOG( TWO )
         LGN = INT( TEMP )
         IF( 2**LGN.LT.N )
     $      LGN = LGN + 1
         IF( 2**LGN.LT.N )
     $      LGN = LGN + 1
         IPRMPT = INDXQ + N + 1
         IPERM = IPRMPT + N*LGN
         IQPTR = IPERM + N*LGN
         IGIVPT = IQPTR + N + 2
         IGIVCL = IGIVPT + N*LGN
*
         IGIVNM = 1
         IQ = IGIVNM + 2*N*LGN
         IWREM = IQ + N**2 + 1
*
*        Initialize pointers
*
         DO 50 I = 0, SUBPBS
            IWORK( IPRMPT+I ) = 1
            IWORK( IGIVPT+I ) = 1
   50    CONTINUE
         IWORK( IQPTR ) = 1
      END IF
*
*     Solve each submatrix eigenproblem at the bottom of the divide and
*     conquer tree.
*
      CURR = 0
      DO 70 I = 0, SPM1
         IF( I.EQ.0 ) THEN
            SUBMAT = 1
            MATSIZ = IWORK( 1 )
         ELSE
            SUBMAT = IWORK( I ) + 1
            MATSIZ = IWORK( I+1 ) - IWORK( I )
         END IF
         IF( ICOMPQ.EQ.2 ) THEN
            CALL SSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),
     $                   Q( SUBMAT, SUBMAT ), LDQ, WORK, INFO )
            IF( INFO.NE.0 )
     $         GO TO 130
         ELSE
            CALL SSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),
     $                   WORK( IQ-1+IWORK( IQPTR+CURR ) ), MATSIZ, WORK,
     $                   INFO )
            IF( INFO.NE.0 )
     $         GO TO 130
            IF( ICOMPQ.EQ.1 ) THEN
               CALL SGEMM( 'N', 'N', QSIZ, MATSIZ, MATSIZ, ONE,
     $                     Q( 1, SUBMAT ), LDQ, WORK( IQ-1+IWORK( IQPTR+
     $                     CURR ) ), MATSIZ, ZERO, QSTORE( 1, SUBMAT ),
     $                     LDQS )
            END IF
            IWORK( IQPTR+CURR+1 ) = IWORK( IQPTR+CURR ) + MATSIZ**2
            CURR = CURR + 1
         END IF
         K = 1
         DO 60 J = SUBMAT, IWORK( I+1 )
            IWORK( INDXQ+J ) = K
            K = K + 1
   60    CONTINUE
   70 CONTINUE
*
*     Successively merge eigensystems of adjacent submatrices
*     into eigensystem for the corresponding larger matrix.
*
*     while ( SUBPBS > 1 )
*
      CURLVL = 1
   80 CONTINUE
      IF( SUBPBS.GT.1 ) THEN
         SPM2 = SUBPBS - 2
         DO 90 I = 0, SPM2, 2
            IF( I.EQ.0 ) THEN
               SUBMAT = 1
               MATSIZ = IWORK( 2 )
               MSD2 = IWORK( 1 )
               CURPRB = 0
            ELSE
               SUBMAT = IWORK( I ) + 1
               MATSIZ = IWORK( I+2 ) - IWORK( I )
               MSD2 = MATSIZ / 2
               CURPRB = CURPRB + 1
            END IF
*
*     Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2)
*     into an eigensystem of size MATSIZ.
*     SLAED1 is used only for the full eigensystem of a tridiagonal
*     matrix.
*     SLAED7 handles the cases in which eigenvalues only or eigenvalues
*     and eigenvectors of a full symmetric matrix (which was reduced to
*     tridiagonal form) are desired.
*
            IF( ICOMPQ.EQ.2 ) THEN
               CALL SLAED1( MATSIZ, D( SUBMAT ), Q( SUBMAT, SUBMAT ),
     $                      LDQ, IWORK( INDXQ+SUBMAT ),
     $                      E( SUBMAT+MSD2-1 ), MSD2, WORK,
     $                      IWORK( SUBPBS+1 ), INFO )
            ELSE
               CALL SLAED7( ICOMPQ, MATSIZ, QSIZ, TLVLS, CURLVL, CURPRB,
     $                      D( SUBMAT ), QSTORE( 1, SUBMAT ), LDQS,
     $                      IWORK( INDXQ+SUBMAT ), E( SUBMAT+MSD2-1 ),
     $                      MSD2, WORK( IQ ), IWORK( IQPTR ),
     $                      IWORK( IPRMPT ), IWORK( IPERM ),
     $                      IWORK( IGIVPT ), IWORK( IGIVCL ),
     $                      WORK( IGIVNM ), WORK( IWREM ),
     $                      IWORK( SUBPBS+1 ), INFO )
            END IF
            IF( INFO.NE.0 )
     $         GO TO 130
            IWORK( I / 2+1 ) = IWORK( I+2 )
   90    CONTINUE
         SUBPBS = SUBPBS / 2
         CURLVL = CURLVL + 1
         GO TO 80
      END IF
*
*     end while
*
*     Re-merge the eigenvalues/vectors which were deflated at the final
*     merge step.
*
      IF( ICOMPQ.EQ.1 ) THEN
         DO 100 I = 1, N
            J = IWORK( INDXQ+I )
            WORK( I ) = D( J )
            CALL SCOPY( QSIZ, QSTORE( 1, J ), 1, Q( 1, I ), 1 )
  100    CONTINUE
         CALL SCOPY( N, WORK, 1, D, 1 )
      ELSE IF( ICOMPQ.EQ.2 ) THEN
         DO 110 I = 1, N
            J = IWORK( INDXQ+I )
            WORK( I ) = D( J )
            CALL SCOPY( N, Q( 1, J ), 1, WORK( N*I+1 ), 1 )
  110    CONTINUE
         CALL SCOPY( N, WORK, 1, D, 1 )
         CALL SLACPY( 'A', N, N, WORK( N+1 ), N, Q, LDQ )
      ELSE
         DO 120 I = 1, N
            J = IWORK( INDXQ+I )
            WORK( I ) = D( J )
  120    CONTINUE
         CALL SCOPY( N, WORK, 1, D, 1 )
      END IF
      GO TO 140
*
  130 CONTINUE
      INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1
*
  140 CONTINUE
      RETURN
*
*     End of SLAED0
*
      END


  SUBROUTINE Bfieldfind
    !
    USE basic
    USE numerics
    USE tracers
    USE fields
    !
    IMPLICIT none
    !
    ! Find the magnetic field for several case:
    ! 1) 'torpex'
    ! 2) 'torus' which is 'torpex' without spatial dependence
    ! 3) 'slab' has the B field in the x direction with magnitude Bnaught
    !
    DOUBLE PRECISION                                      :: A=0.
    DOUBLE PRECISION, DIMENSION(ndim_tracer)              :: B

    B_cart = 0.
    B = 0.

    IF (Bfield_type=='torpex') THEN
      A    = Rcurv/(pos_cart(1)**2+pos_cart(2)**2) ! find ratio of curvature radius to r^2
      B(1) = -1.0*A*pos_cart(2)*B_t
      B(2) =      A*pos_cart(1)*B_t
      B(3) = Bratio
    ELSE IF (Bfield_type=='torus') THEN
      B(1) = -1.0*B_t
      B(2) =  1.0*B_t
      B(3) = Bratio
    ELSE IF (Bfield_type=='slab') THEN
      B(1) = 0.
      B(2) = By
      B(3) = 0.
    ELSE
      B = 0.
    END IF

    B_cart = B*red_mass

  END SUBROUTINE Bfieldfind


       subroutine runC_0000(k,l,DetGr,f,Gtwiddle,Gtt,
     . Shat3zz,Shat4zz,S0000,N0)
      implicit none
      include 'TRconstants.f'
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,k,l,n,m,np
      parameter(np=2)
      double precision DetGr,Gtwiddle(np,np),Gtt(np,np,np,np),f(np)
      double complex Shat3zz(np,-2:0),S0000(-2:0),
     . Shat4zz(np,z1max,-2:0),bit,pole

      do ep=-2,0
      bit=czip
      do n=1,np
      do m=1,np
      bit=bit
     . +Gtt(k,n,l,m)*(f(n)*Shat3zz(m,ep)-f(n)*f(m)*Cv(cc00+N0,ep))
      enddo
      enddo
      pole=czip
      if (ep .gt. -2) pole=-4d0*Gtwiddle(k,l)*Cv(cc0000+N0,ep-1)

      Cv(cc0000+N0,ep)=-(
     . +pole
     . +DetGr*Cv(czzii(z2(k,l))+N0,ep)
     . -Gtwiddle(k,l)*S0000(ep)
     . -Gtwiddle(1,l)*Shat4zz(1,k,ep)
     . -Gtwiddle(2,l)*Shat4zz(2,k,ep)
     . +Gtwiddle(k,l)*(Shat4zz(1,1,ep)+Shat4zz(2,2,ep))
     . +bit)/(10d0*Gtwiddle(k,l))

c      if (ep .eq. -1) then
c      write(6,*) 'C0000 ',k,l,
c     . +pole/(10d0*Gtwiddle(k,l))
c      write(6,*) 'C0000 ',k,l,
c     . +DetGr*Cv(czzii(z2(k,l))+N0,ep)/(10d0*Gtwiddle(k,l))
c      write(6,*) 'C0000 ',k,l,
c     . -Gtwiddle(k,l)*S0000(ep)/(10d0*Gtwiddle(k,l))
c      write(6,*) 'C0000 ',k,l,
c     . -Gtwiddle(1,l)*Shat4zz(1,k,ep)/(10d0*Gtwiddle(k,l))
c      write(6,*) 'C0000 ',k,l,
c     . -Gtwiddle(2,l)*Shat4zz(2,k,ep)/(10d0*Gtwiddle(k,l))
c      write(6,*) 'C0000 ',k,l,
c     . +Gtwiddle(k,l)*(Shat4zz(1,1,ep)+Shat4zz(2,2,ep))
c     .  /(10d0*Gtwiddle(k,l))
c      write(6,*) 'C0000 ',k,l,
c     . +bit/(10d0*Gtwiddle(k,l))
c      endif
      enddo

      return
      end


      subroutine eltpp(errc)
************************************************************************
*
*   ELTPP -- Element term pre-processor.
*
************************************************************************
      include "parameters.h"

      integer nnod,nelt
      common /mfe010/ nnod,nelt

      double precision fdinc,dxmin
      common /mfe022/ fdinc,dxmin

      double precision u0,x0,u1,x1
      common /loc10/ u0(mnod,npde),x0(mnod),u1(mnod,npde),x1(mnod)

      double precision l,n1,n2,du,dx
      common /loc30/ l(mnod,npde),n1(mnod,npde),n2(mnod,npde)
      common /loc31/ du(mnod,npde),dx(mnod)

      double precision dx2(mnod)
      integer errc,j,k

      do 10 j=1,nelt
       dx(j) = x1(j) - x0(j)
       if(dx(j) .lt. dxmin) then
         errc = j
         return
         endif
       dx2(j) = dx(j)**2
   10 continue

      do 20 k=1,npde
      do 20 j=1,nelt
       du(j,k) = u1(j,k) - u0(j,k)
       l(j,k) = sqrt(du(j,k)**2 + dx2(j))
       n1(j,k) = -du(j,k)/l(j,k)
       n2(j,k) = dx(j)/l(j,k)
   20 continue

      errc = 0
      return
      end


*----------------------------------------------------------------------*
!>    a subroutine to orthogonalize a vector with respect to a subspace( assumed to be already orthogonal)
!!
!!    @param vecsp the vectorspace
!!    @param me_lists the lists of the vector
!!    @param nlists the number of lists in the vector
*----------------------------------------------------------------------*
      subroutine vecsp_orthvec(vecsp, me_lists, nlists,
     $     xbuf1, xbuf2, lbuf)
*----------------------------------------------------------------------*
      implicit none
      include 'stdunit.h'
      include 'mdef_me_list.h'
      include 'def_file_array.h'
      include 'def_davidson_subspace.h'

      integer, parameter::
     &     ntest = 00
      character(len=*),parameter::
     &     i_am="vecsp_orthvec"

      integer,intent(in)::
     &     nlists, lbuf
      type(vector_space_t), intent(inout)::
     &     vecsp
      type(me_list_array),intent(in)::
     &     me_lists(*)
      real(8),intent(inout)::
     &     xbuf1(*),xbuf2(*)

      real(8)::
     &     xnorm,
     &     fac
      real(8),allocatable::
     &     contrib(:)

      integer::
     &     nvec,
     &     ivec,
     &     ilist,
     &     lenlist,
     &     irec,
     &     nblock,
     &     njoined

      type(filinf),pointer::
     &     ffme,ffvec
      real(8),external::
     &     da_ddot

      nvec=vecsp%nvec
      allocate(contrib(1:nvec))
      contrib(1:nvec)=0d0

      do ilist=1,nlists
         ffme=> me_lists(ilist)%mel%fhand
         irec=me_lists(ilist)%mel%fhand%current_record
         ffvec => vecsp%vectors(ilist)%fhand
         lenlist= me_lists(ilist)%mel%len_op
         do ivec=1,nvec
            contrib(ivec)=contrib(ivec)
     &           +da_ddot(ffme, irec,ffvec,  ivec, lenlist,
     &           xbuf1, xbuf2, lbuf)

         end do
      end do
      do ilist=1,nlists
         ffme=> me_lists(ilist)%mel%fhand
         irec=me_lists(ilist)%mel%fhand%current_record
         ffvec => vecsp%vectors(ilist)%fhand
         lenlist= me_lists(ilist)%mel%len_op
         call vec_from_da(ffme,irec,xbuf1,lenlist)
         do ivec=1,nvec
            call  vecsp_get_list_buf(vecsp, ivec, ilist, lenlist,
     &           xbuf2, lbuf)
            xbuf1(1:lenlist)=xbuf1(1:lenlist)
     &           -contrib(ivec)*xbuf2(1:lenlist)
         end do
         call vec_to_da(ffme,irec,xbuf1,lenlist)
      end do
      end subroutine


program grid_mapping_test_driver
  !=======================================================================
  ! Purpose(s):
  !
  !    Driver to test GRID_MAPPING_MODULE.
  !
  ! Author(s): Andrew Kuprat (kuprat@lanl.gov)
  !
  !=======================================================================
  use grid_mapping_utils, only : read_ascii_gm_mesh,writegmv_gm_mesh
  use grid_mapping_module, only : grid_int_vols, &
       read_int_volumes, compute_int_volumes, &
       grid_vols, grid_vol_fracs, write_int_volumes, map_cell_field, &
       destroy_grid_int_vols, right_int_volumes, gm_mesh, &
       destroy_gm_mesh,size_int_volumes

  implicit none

  integer, parameter :: dp=kind(1.0d0)

  integer, parameter :: task_lun=8, grid_lun=9, gmv_lun=10, file_lun=12
  character(80) :: taskfile,filename_mesh_a,filename_mesh_b,label
  character(80) :: title1,title2,title3,fname
  logical :: reverse_order,exactly_conservative,preserve_constants,strict
  logical :: map_exists
  real(dp) :: defval
  type(gm_mesh) :: mesh_a, mesh_b
  type(grid_int_vols) :: int_vols
  real(dp), dimension(:), pointer :: field_a=>null(), field_b=>null(), vol_a=>null(), vol_b=>null()
  real(dp), dimension(:), pointer :: vf_a=>null(), vf_b=>null()
  real(dp) :: minval_a, maxval_a, minval_b, maxval_b
  integer :: ier,i,j, nrows, ncols, numentries
  real(dp), dimension(3) :: xq
  real(dp), dimension(:,:), pointer :: pos_elt => null()
  real(dp) :: timef_delta, t0, t1, t2

  t0=0.d0

  taskfile='taskfile'
  open (task_lun,file=taskfile)

  do

     read (task_lun,*,end=20) title1
     read (task_lun,*) title2
     read (task_lun,*) title3
     read (task_lun,*) label, filename_mesh_a
     read (task_lun,*) label, filename_mesh_b
     read (task_lun,*) label, reverse_order
     read (task_lun,*) label, exactly_conservative
     read (task_lun,*) label, preserve_constants
     read (task_lun,*) label, strict
     read (task_lun,*) label, defval

     write(*,fmt='(/,a)') trim(title1)
     write(*,fmt='(a)') trim(title2)
     write(*,fmt='(a)') trim(title3)
     write(*,fmt='(2a)') 'filename_mesh_a= ',trim(filename_mesh_a)
     write(*,fmt='(2a)') 'filename_mesh_b= ',trim(filename_mesh_b)
     write(*,fmt='(a,l1)') 'reverse_order= ',reverse_order
     write(*,fmt='(a,l1)') 'exactly_conservative= ',exactly_conservative
     write(*,fmt='(a,l1)') 'preserve_constants= ',preserve_constants
     write(*,fmt='(a,l1)') 'strict= ',strict
     write(*,fmt='(a,es20.12)') 'defval= ',defval

     ! Release meshes if necessary
     call destroy_gm_mesh(mesh_a)
     call destroy_gm_mesh(mesh_b)

     ! Read two meshes from ascii files
     open(UNIT=file_lun,FILE=filename_mesh_a,POSITION='rewind')
     call read_ascii_gm_mesh(file_lun,mesh_a)
     close(unit=file_lun)

     open(UNIT=file_lun,FILE=filename_mesh_b,POSITION='rewind')
     call read_ascii_gm_mesh(file_lun,mesh_b)
     close(unit=file_lun)

     fname=trim(title2)//'_meshes_ab.gmv'
     open (unit=gmv_lun, FILE=fname, IOSTAT=ier, POSITION='rewind')
     call writegmv_gm_mesh(gmv_lun,mesh_a,mesh_b)
     close (unit=gmv_lun)

     ! Does the right mapping file already exist on disk?
     map_exists = .false.

     OPEN (UNIT = grid_lun, FILE='int_vols_file', STATUS='old', IOSTAT=ier, POSITION='rewind', &
          FORM = 'unformatted')

     if (ier.eq.0) then

        call read_int_volumes(int_vols, grid_lun, ier)
        close(grid_lun)
        if (ier.eq.0) then
           map_exists = right_int_volumes(mesh_a, mesh_b, int_vols)
        endif

     endif

     if (.not.map_exists) then

        write(*,fmt='(/,a,/)') '*** Recomputing grid mapping'

        t1=timef_delta(t0)
        call compute_int_volumes(mesh_a,mesh_b,int_vols,maxwarn=1000,ier=ier)
        t2=timef_delta(t1)
        print*,'compute_int_volumes: elapsed time in mS: ',t2
        call size_int_volumes(int_vols,nrows,ncols,numentries)
        print*,' '
        print*,'size of mesh_a = ',ncols
        print*,'size of mesh_b = ',nrows
        print*,'number of entries in sparse overlap matrix = ',numentries
        print*,' '
        if (ier.ne.0) stop

        ! Write grid-grid overlap statistics
        if (associated(vol_a)) deallocate(vol_a)
        allocate(vol_a(mesh_a%nelt))
        if (associated(vol_b)) deallocate(vol_b)
        allocate(vol_b(mesh_b%nelt))

        call grid_vols(int_vols,vol_a,vol_b)
        minval_a=minval(vol_a)
        maxval_a=maxval(vol_a)
        minval_b=minval(vol_b)
        maxval_b=maxval(vol_b)

        write(*,fmt='(a,es20.12)') 'A mesh has MIN VOLUME= ',minval_a
        write(*,fmt='(a,es20.12)') 'A mesh has MAX VOLUME= ',maxval_a
        write(*,fmt='(a,es20.12)') 'B mesh has MIN VOLUME= ',minval_b
        write(*,fmt='(a,es20.12)') 'B mesh has MAX VOLUME= ',maxval_b

        deallocate (vol_a)
        deallocate (vol_b)

        if (associated(vf_a)) deallocate(vf_a)
        allocate(vf_a(mesh_a%nelt))
        if (associated(vf_b)) deallocate(vf_b)
        allocate(vf_b(mesh_b%nelt))

        call grid_vol_fracs(int_vols,vf_a,vf_b,strict=.true.)
        minval_a=minval(vf_a)
        maxval_a=maxval(vf_a)
        minval_b=minval(vf_b)
        maxval_b=maxval(vf_b)

        write(*,fmt='(/,a)')         'Respecting block IDs, we have that'
        write(*,fmt='(a,es20.12)') 'A mesh elts have MIN VF in B mesh= ',minval_a
        write(*,fmt='(a,es20.12)') 'A mesh elts have MAX VF in B mesh= ',maxval_a
        write(*,fmt='(a,es20.12)') 'B mesh elts have MIN VF in A mesh= ',minval_b
        write(*,fmt='(a,es20.12/)') 'B mesh elts have MAX VF in A mesh= ',maxval_b
        deallocate (vf_a)
        deallocate (vf_b)

        ! Write to disk for possible future use
        OPEN (UNIT = grid_lun, FILE='int_vols_file', IOSTAT=ier, POSITION='rewind',FORM='unformatted')

        if (ier.eq.0) then
           call write_int_volumes(int_vols,grid_lun)
           close(grid_lun)
        endif

     else

        write(*,fmt='(/,a,/)') '*** Reusing grid mapping'

     endif

     ! Allocate fields
     if (associated(field_a)) deallocate(field_a)
     allocate(field_a(mesh_a%nelt))
     if (associated(field_b)) deallocate(field_b)
     allocate(field_b(mesh_b%nelt))

     if (.not.reverse_order) then

        ! Test out mapping field_a to field_b with field_a=1+sin(z)

        if (associated(pos_elt)) deallocate(pos_elt)
        allocate(pos_elt(3,size(mesh_a%node_elt,1)))
        do i=1,size(mesh_a%node_elt,2)
           do j=1,size(pos_elt,2)
              pos_elt(:,j)=mesh_a%pos_node(:,mesh_a%node_elt(j,i))
           enddo
           xq=sum(pos_elt,2)/size(pos_elt,2)
           field_a(i)=1.d0+sin(xq(3))
        enddo

        t1=timef_delta(t0)
        call map_cell_field(field_a,field_b,int_vols, &
             reverse_order,exactly_conservative,preserve_constants, &
             strict, defval)
        t2=timef_delta(t1)
        print*,'map_cell_field: elapsed time in mS: ',t2
        print*,' '

     else

        ! Test out mapping field_b to field_a with field_b=1+sin(z)

        if (associated(pos_elt)) deallocate(pos_elt)
        allocate(pos_elt(3,size(mesh_b%node_elt,1)))
        do i=1,size(mesh_b%node_elt,2)
           do j=1,size(pos_elt,2)
              pos_elt(:,j)=mesh_b%pos_node(:,mesh_b%node_elt(j,i))
           enddo
           xq=sum(pos_elt,2)/size(pos_elt,2)
           field_b(i)=1.d0+sin(xq(3))
        enddo

        t1=timef_delta(t0)
        call map_cell_field(field_b,field_a,int_vols, &
             reverse_order,exactly_conservative,preserve_constants, &
             strict, defval)
        t2=timef_delta(t1)
        print*,'map_cell_field: elapsed time in mS: ',t2
        print*,' '

     endif

! Dump out mesh_a, mesh_b, and a superposition of mesh_a and mesh_b
     fname=trim(title2)//'_mesh_a.gmv'
     open (unit=gmv_lun, FILE=fname, IOSTAT=ier, POSITION='rewind')
     call writegmv_gm_mesh(gmv_lun,mesh_a,field=field_a)
     close (unit=gmv_lun)

     fname=trim(title2)//'_mesh_b.gmv'
     open (unit=gmv_lun, FILE=fname, IOSTAT=ier, POSITION='rewind')
     call writegmv_gm_mesh(gmv_lun,mesh_b,field=field_b)
     close (unit=gmv_lun)

     fname=trim(title2)//'_meshes_ab.gmv'
     open (unit=gmv_lun, FILE=fname, IOSTAT=ier, POSITION='rewind')
     call writegmv_gm_mesh(gmv_lun,mesh_a,mesh_b)
     close (unit=gmv_lun)

     minval_a=minval(field_a)
     maxval_a=maxval(field_a)
     minval_b=minval(field_b)
     maxval_b=maxval(field_b)

     write(*,fmt='(a,es20.12)') 'field_a has MINVAL= ',minval_a
     write(*,fmt='(a,es20.12)') 'field_a has MAXVAL= ',maxval_a
     write(*,fmt='(a,es20.12)') 'field_b has MINVAL= ',minval_b
     write(*,fmt='(a,es20.12)') 'field_b has MAXVAL= ',maxval_b

     ! Allocate Volume fields
     if (associated(vol_a)) deallocate(vol_a)
     allocate(vol_a(mesh_a%nelt))
     if (associated(vol_b)) deallocate(vol_b)
     allocate(vol_b(mesh_b%nelt))

     call grid_vols(int_vols,vol_a,vol_b)
     write(*,fmt='(/,a,es20.12)') 'Integral on A mesh= ',dot_product(vol_a,field_a)
     write(*,fmt='(a,es20.12)') 'Integral on B mesh= ',dot_product(vol_b,field_b)

     call destroy_grid_int_vols(int_vols)
  enddo

20 continue
  close(task_lun)
  stop

end program grid_mapping_test_driver


    program my_practice
        implicit none

        real, dimension (1:5)   :: current, voltage, complex_power
        real                    :: energy

        integer :: i, n=5

        print *, 'Hello World!'

        i = 1           ! Intialize counter variable

        ! Open data files that contains current utilization data and line voltage data,
        ! one element per line, and in floating point format
        open (unit=1, file="current.dat", status="old")
        open (unit=20, file="voltage.dat", status="old")

        ! Traverse through data file and fill array up with data element in file
        do i = 1,n

            read (1, '(f20.10)', END = 1000, ERR = 1000), current(i)
            print *, 'The data element read from current.dat file was ->'
            print '(f20.10)', current(i)

            read (20, '(f20.10)', END = 2000, ERR = 2000), voltage(i)
            print *, 'The data element read from voltage.dat file was ->'
            print '(f20.10)', voltage(i)

        end do

        !voltage = (/50.0, 50.0, 50.0, 50.0, 50.0/)

        complex_power = voltage * current

        print *, 'The calculated power dissipation is ->'
        print '(f20.10)', complex_power

        print *, 'Below is a list of the cumulative energy ->'
        do i = 1,(n)
            energy = energy + (complex_power(i)*i)
            print '(f20.10)', energy
        end do

        print *, 'The accumulated energy is ->'
        print '(f20.10)', energy

1000    close (1)
2000    close (20)
        print *, 'Program completed'

        end program my_practice


!--------------------------------------------------------------------------------------------------
! MODULE: constants
!
! DESCRIPTION:
!> @brief Definitions of constants and unit conversion factors.
!--------------------------------------------------------------------------------------------------
module constants
    use global_defs, only : dp

    !----------------------------------------------------------------------------------------------
    ! Unit conversions.
    !----------------------------------------------------------------------------------------------
    real(dp), parameter :: Da_me = 1822.88849_dp !< Dalton (unified atomic mass) to electron rest mass.
    real(dp), parameter :: a0_A = 0.52917721067_dp !< Bohr radius to Angstrom.
    real(dp), parameter :: aut_fs = 0.02418884326509_dp !< Atomic unit of time to femtosecond.
    real(dp), parameter :: aut_ps = 0.00002418884326509_dp !< Atomic unit of time to picosecond.
    real(dp), parameter :: eh_k = 315775.13_dp !< Hartree to Kelvin.
    real(dp), parameter :: eh_cm1 = 219474.6313702_dp !< Hartree to reciprocal centimeter.
    real(dp), parameter :: eh_eV = 27.21138602_dp !< Hartree to electronvolt.
    real(dp), parameter :: kcalmol_eh = 0.001593601_dp !< kcal/mol to Hartree.

end module constants


module segment_tree_mod
    use,intrinsic :: iso_fortran_env
    implicit none
    abstract interface
        function operator(x,y) result(ret)
            use, intrinsic:: iso_fortran_env
            integer(int32),intent(in):: x,y
            integer(int32):: ret
        end function
    end interface
    private
    public:: seg_tree, st_from_array
    type,public:: seg_tree
        integer(int32),private:: n, elnum
        integer(int32),allocatable,private:: v(:)
        procedure(operator),pointer,nopass,private:: op => null()
        integer(int32),private:: e
    contains
        procedure:: at => st_at
        procedure:: update => st_update
        procedure:: query => st_query
        procedure:: to_array => st_to_array
    end type

    interface seg_tree
        module procedure:: st_init
    end interface
contains
    function st_init(n, op, e) result(st)
        type(seg_tree):: st
        procedure(operator):: op
        integer(int32),intent(in):: n,e
        integer(int32):: x

        st%op => op
        st%e = e
        st%elnum = n
        x=1
        do while(n > x)
            x = 2*x
        end do
        st%n = x
        allocate(st%v(2*x-1), source=e)
    end function

    function st_from_array(ar, op, e) result(st)
        type(seg_tree):: st
        procedure(operator):: op
        integer(int32),intent(in):: ar(:),e
        integer(int32):: x,i

        st%op => op
        st%e = e
        st%elnum = size(ar)
        x=1
        do while(size(ar) > x)
            x = 2*x
        end do
        st%n = x
        allocate(st%v(2*x-1), source=e)
        st%v(x:x+st%elnum-1) = ar(:)
        do i=x-1,1,-1
            st%v(i) = st%op(st%v(2*i), st%V(2*i+1))
        end do
    end function

    function st_at(st,i) result(ret)
        class(seg_tree):: st
        integer(int32):: i,ret

        ret = st%v(st%n-1+i)
    end function

    subroutine st_update(st, i, x)
        class(seg_tree):: st
        integer(int32), intent(in):: i
        integer(int32):: ind
        integer(int32), intent(in):: x

        ind = i+st%n-1
        st%v(ind) = x
        do while(ind > 1)
            ind = ind/2
            st%v(ind) = st%op(st%v(2*ind), st%v(2*ind+1))
        end do
    end subroutine

    function st_query(st, a, b) result(ret)
        class(seg_tree):: st
        integer(int32), intent(in):: a,b
        integer(int32):: ret,l,r

        l=a+st%n-1; r=b+st%n-1
        ret = st%e
        do while (l <= r)
            if (      btest(l,0)) ret = st%op(st%v(l), ret)
            if (.not. btest(r,0)) ret = st%op(st%v(r), ret)
            l=(l+1)/2; r=(r-1)/2
        end do
    end function

    function st_to_array(st) result(ret)
        class(seg_tree):: st
        integer(int32):: ret(st%elnum)

        ret(:) = st%v(st%n:st%n+st%elnum-1)
    end function
end module


C       CSCI3180 Principles of Programming Languages
C       --- Declaration ---
C       I declare that the assignment here submitted
C       is original except for source material explicitly
C       acknowledged. I also acknowledge that I am aware of
C       University policy and regulations on honesty in
C       academic work, and of the disciplinary guidelines
C       and procedures applicable to breaches of such policy
C       and regulations, as contained in the website
C       http://www.cuhk.edu.hk/policy/academichonesty/
C       Assignment 1
C       Name:
C       Student ID:
C       Email Addr:

        PROGRAM dda
           IMPLICIT NONE
           integer a, b, n, h, i, j, k, xi, yi, xj, yj
           integer fio, io
           real m
           character c
           character graph(23,79)

C          initialize the array and draw axis
           i = 23
           j = 1
010        IF (i .GE. 1) GOTO 020
015        GOTO 040
020           IF (j .LE. 79) GOTO 030
025           GOTO 040
C                print *, i, j
030              graph(i,j) = ' '
                 IF (i .EQ. 1 .AND. j .EQ. 1) GOTO 033
                 IF (j .EQ. 1) GOTO 031
                 IF (i .EQ. 1) GOTO 032
                 GOTO 035
031              graph(i,j) = '|'
                 GOTO 035
032              graph(i,j) = '-'
                 GOTO 035
033              graph(i,j) = '+'
                 GOTO 035
035              j = j + 1
                 IF (j .GT. 79) GOTO 038
                 GOTO 020
038                 j = 1
                    i = i - 1
                    GOTO 010
C          =========================================

C          start reading file input
040        open(unit=1234,file="input.txt",status='old',IOSTAT=fio)
           if (fio .NE. 0) GOTO 050
           GOTO 060
050        PRINT *,"Cannot open input.txt"
           PRINT *,"Program terminates"
           GOTO 340
C          read the first line (number of points)
060        k = 1
           read (1234,*) n

C          read the first point
           k = 2
           read (1234,*, end=340) a,b
           xj = a
           yj = b

C          check whether we have read all points
100        IF (k .LE. n) GOTO 105
           GOTO 300
105           k = k + 1
              GOTO 110

C          read the next point
110        read (1234,111, IOSTAT=io) a,c,b
111        format (I2,A1,I2)
C          print *, a,b
           xi = xj
           yi = yj
           xj = a
           yj = b
C          handle divide by zero first
           IF (xj .NE. xi) GOTO 112
           m = float(999)
           GOTO 210
112        m = float(yj - yi) / float(xj - xi)

C          Case 1 : |m| <= 1
210        IF (m .LE. 1 .AND. m .GE. -1) GOTO 211
           GOTO 220
211           i = 0
              a = xj
              b = yj
              h = xi - xj
212           IF (xi .LT. xj) GOTO 213
              GOTO 214
213              a = xi
                 b = yi
                 h = xj - xi
214           IF (i .LE. h) GOTO 215
              GOTO 220
215              j = nint(b + i * m)
                 graph(j+1,a+i+1) = '*'
                 i = i + 1
                 GOTO 214

C          Case 2 : |m| > 1
220        IF (m .GT. 1 .OR. m .LT. -1) GOTO 221
           GOTO 299
221           i = 0
              a = xj
              b = yj
              h = yi - yj
222           IF (yi .LT. yj) GOTO 223
              GOTO 224
223              h = yj - yi
                 a = xi
                 b = yi
224           IF (i .LE. h) GOTO 225
              GOTO 299
225              j = nint(a + i / m)
C                special case for vertical lines
                 IF (m .GT. 998) GOTO 226
                 GOTO 227
226              j = a
227              graph(b+i+1,j+1) = '*'
                 i = i + 1
                 GOTO 224

299        graph(yi+1,xi+1) = '*'
           graph(yj+1,xj+1) = '*'
           GOTO 100
C          =========================================

C          Display the graph
300        i = 23
           j = 1
310        IF (i .GE. 1) GOTO 320
315        GOTO 340
320           IF (j .LE. 79) GOTO 330
325           GOTO 340
330              write (*,"(a,$)"), graph(i,j)
                 j = j + 1
                 IF (j .GT. 79) GOTO 335
                 GOTO 320
335                 write (*,"(a)"), ""
                    j = 1
                    i = i - 1
                    GOTO 310
340     close(1234, iostat=fio)
        END