     SUBROUTINE FLEPO (XPARAM,NVAR,FUNCT1)
     IMPLICIT DOUBLE PRECISION (A-H,O-Z)
     INCLUDE 'SIZES/NOLIST'
     DIMENSION XPARAM(*)
     COMMON /KEYWRD/ KEYWRD
     COMMON /LAST  / LAST
     COMMON /PATH  / LATOM,LPARAM,REACT(100)
     COMMON /GRADNT/ GRAD(MAXPAR),GNORM
     COMMON /MESAGE/ IFLEPO,ISCF
     COMMON /TIME  / TIME0
     COMMON /FMATRX/ HESINV(MAXHES)
     COMMON /NUMCAL/ NUMCAL
     COMMON /GRAVEC/ COSINE
     CHARACTER*80 KEYWRD

     *
     THIS SUBROUTINE ATTEMPTS TO MINIMIZE A REAL-VALUED FUNCTION OF
     THE N-COMPONENT REAL VECTOR XPARAM ACCORDING TO THE
     DAVIDON-FLETCHER-POWELL ALGORITHM (COMPUTER JOURNAL, VOL. 6,
     P. 163).  THE USER MUST SUPPLY THE SUBROUTINE
     COMPFG(NVAR,XPARAM,FUNCT,GRAD,1)
     WHICH COMPUTES FUNCTION VALUES  FUNCT  AND GRADIENTS  GRAD  AT GIVEN
     VALUES FOR THE VARIABLES XPARAM.  THE MINIMIZATION PROCEEDS BY A
     SEQUENCE OF ONE-DIMENSIONAL MINIMIZATIONS.  THESE ARE CARRIED OUT
     BY THE SUBROUTINE LINMIN, WHICH SOLVES THE SUBPROBLEM OF
     MINIMIZING THE FUNCTION FUNCT ALONG THE LINE XPARAM+ALPHA*PVECT,
     WHERE XPARAM
     IS THE VECTOR OF CURRENT VARIABLE VALUES,  ALPHA IS A SCALAR
     VARIABLE, AND  PVECT  IS A SEARCH-DIRECTION VECTOR PROVIDED BY THE
     DAVIDON-FLETCHER-POWELL ALGORITHM.  EACH ITERATION STEP CARRIED
     OUT BY FLEPO PROCEEDS BY LETTING LINMIN FIND A VALUE FOR ALPHA
     WHICH MINIMIZES  FUNCT  ALONG  XPARAM+ALPHA*PVECT, BY
     UPDATING THE VECTOR  XPARAM  BY THE AMOUNT ALPHA*PVECT, AND FINALLY BY
     GENERATING A NEW VECTOR  PVECT.  UNDER CERTAIN RESTRICTIONS
     (POWELL, J.INST.MATHS.APPLICS.(1971),V.7,21-36)  A SEQUENCE OF
     FUNCT VALUES CONVERGING TO SOME LOCAL MINIMUM VALUE AND A SEQUENCE OF
     XPARAM VECTORS CONVERGING TO THE CORRESPONDING MINIMUM POINT
     ARE PRODUCED.
                          CONVERGENCE TESTS.

     HERBERTS TEST: THE ESTIMATED DISTANCE FROM THE CURRENT POINT
                    POINT TO THE MINIMUM IS LESS THAN TOLERA.

                    "HERBERTS TEST SATISFIED - GEOMETRY OPTIMISED"

     GRADIENT TEST: THE GRADIENT NORM HAS BECOME LESS THAN TOLERG
                    TIMES THE SQUARE ROOT OF THE NUMBER OF VARIABLES.

                    "TEST ON GRADIENT SATISFIED".

     XPARAM TEST:   THE RELATIVE CHANGE IN XPARAM, MEASURED BY ITS NORM,
                    OVER ANY TWO SUCCESSIVE ITERATION STEPS DROPS BELOW
                    TOLERX.

                    "TEST ON XPARAM SATISFIED".

     FUNCTION TEST: THE CALCULATED VALUE OF THE HEAT OF FORMATION
                    BETWEEN ANY TWO CYCLES IS WITHIN TOLERF OF EACH OTHER.

                    "HEAT OF FORMATION TEST SATISFIED"

     FOR THE GRADIENT, FUNCTION, AND XPARAM TESTS A FURTHER CONDITION,
     THAT NO INDIVIDUAL COMPONENT OF THE GRADIENT IS GREATER
     THAN TOLERG, MUST BE SATISFIED, IN WHICH CASE THE
     CALCULATION EXITS WITH THE MESSAGE

                     "PETERS TEST SATISFIED"

     AN UNSUCCESSFUL TERMINATION WILL TAKE PLACE AFTER
     COMPFG HAS BEEN CALLED MORE TIMES THAN THE USER-SUPPLIED VALUE
     OF MAXEND.  IN THIS CASE THE COMMENT

                     "*** TERMINATION FROM TOO MANY COUNTS ***"

     WILL BE PRINTED, AND FUNCT AND XPARAM WILL CONTAIN THE LAST FUNCTION
     VALUE CUM VARIABLE VALUES REACHED.

     SIMILAR UNSUCCESSFUL TERMINATIONS WILL TAKE PLACE IF THE COSINE OF
     THE SEARCH DIRECTION TO GRADIENT VECTOR IS LESS THAN RST ON TWO
     CONSECUTIVE ITERATIONS.

     THE DAVIDON-FLETCHER-POWELL ALGORITHM CHOOSES SEARCH DIRECTIONS
     ON THE BASIS OF LOCAL PROPERTIES OF THE FUNCTION.  A MATRIX  H,
     WHICH IN FLEPO IS PRESET WITH THE IDENTITY, IS MAINTAINED AND
     UPDATED AT EACH ITERATION STEP.  THE MATRIX DESCRIBES A LOCAL
     METRIC ON THE SURFACE OF FUNCTION VALUES ABOVE THE POINT XPARAM.
     THE SEARCH-DIRECTION VECTOR  PVECT  IS SIMPLY A TRANSFORMATION
     OF THE GRADIENT  GRAD  BY THE MATRIX H.  THE USER MAY THROW OUT  H
     AFTER EACH  NRST ITERATION STEPS  (RESTARTING WITH THE IDENTITY)
     OR WHENEVER THE COSINE OF THE ANGLE BETWEEN  GRAD  AND  PVECT  BECOMES
     LESS THAN RST. THIS CAN BE SUPPRESSED ENTIRELY IF NRST .GT. MAXEND
     AND RST .LT. 0.0.   RESTARTING IS DISCUSSED MARGINALLY IN THE
     PAPER BY FLETCHER AND POWELL, BUT THERE ARE NO GOOD RULES ABOUT
     WHEN OR WHETHER THIS SHOULD BE DONE FOR ANY GIVEN FUNCTION.

     DIMENSION XD(MAXPAR), GD(MAXPAR), GLAST(MAXPAR), MDFP(9),XDFP(9),
    +          XLAST(MAXPAR), GG(MAXPAR), PVECT(MAXPAR)
     LOGICAL OKF, OKC, PRINT,  TIME, RESTRT, MINPRT, SADDLE, GEOOK
    +        ,RESET
     EQUIVALENCE (MDFP(1),JCYC  ),(MDFP(2),JNRST),(MDFP(3),NCOUNT),
    +            (MDFP(4),LNSTOP),(XDFP(1),ALPHA),(XDFP(2),COS   ),
    1            (XDFP(3),PNORM ),(XDFP(4),YEAD ),(XDFP(5),DEL   ),
    2            (XDFP(6),FREPF ),(XDFP(7),CYCMX)
     DATA ICALCN /0/
     IF (ICALCN.NE.NUMCAL) THEN

   THE FOLLOWING CONSTANTS SHOULD BE SET BY THE USER.

     RST   = 0.05D0
     MAXEND= 9999
     TDEL  = 6.D0
     NRST  = 30
     SFACT=1.5
     PMSTE = 0.1D0
     DELL  = 0.01D0
     EINC  = 0.3D0
     IGG1  = 3
     DEL=DELL

    THESE CONSTANTS SHOULD BE SET BY THE PROGRAM.

     RESTRT   = (INDEX(KEYWRD,'RESTART').NE.0)
     GEOOK   = (INDEX(KEYWRD,'GEO-OK').NE.0)
     TIME   = (INDEX(KEYWRD,'TIME').NE.0)
     TLEFT=3600
     GNLIM=1.D0
     IF(INDEX(KEYWRD,'GNORM=').NE.0)
    + GNLIM=READA(KEYWRD,INDEX(KEYWRD,'GNORM='))
     IF(INDEX(KEYWRD,'PARA') .NE. 0) TLEFT=1.D12
     MINPRT=(LATOM+INDEX(KEYWRD,'SADDLE')+INDEX(KEYWRD,'PARA')+
    +INDEX(KEYWRD,'SADDLE') .EQ.0)
     SADDLE=(INDEX(KEYWRD,'SADDLE') .NE.0)
     IF( .NOT. MINPRT) MINPRT=(INDEX(KEYWRD,'DEBUG') .NE. 0)
     I=INDEX(KEYWRD,' T=')
     IF(I.NE.0) TLEFT=READA(KEYWRD,I)
     TX2=SECOND()
     TLEFT=TLEFT-TX2+TIME0
     PRINT  = (INDEX(KEYWRD,'FLEPO').NE.0)
     TOLERX = 0.0001D0
     EYEAD  = 0.0005D0
     TOLERF = 0.002D0
     TOLERG = 0.5D0
     TOLRG  = TOLERG
     IF (INDEX(KEYWRD,'FORCE') .NE. 0) THEN
         TOLERX = 0.00001D0
         TOLERF = 0.0002D0
         TOLERG = 0.05D0
         EYEAD  = 0.00005D0
     ENDIF
     IF(INDEX(KEYWRD,'PREC') .NE. 0) THEN
         TOLERX=TOLERX*0.01D0
         EYEAD=EYEAD*0.01D0
         TOLERF=TOLERF*0.01D0
         TOLERG=TOLERG*0.01D0
     ENDIF
     ENDIF

     THE FOLLOWING CONSTANTS SHOULD BE SET TO SOME ARBITARY LARGE VALUE.

     YEAD  = 1.D15
     FREPF = 1.D15

     AND FINALLY, THE FOLLOWING CONSTANTS ARE CALCULATED.

     IHDIM=(NVAR*(NVAR+1))/2
     CCN=DFLOAT(NVAR)
     ROOTV=SQRT(CCN+1.D-5)
     CNCADD=1.0D00/ROOTV
     IF (CNCADD.GT.0.15D00) CNCADD=0.15D00

     FIRST, WE INITIALISE THE VARIABLES.

     JCYC=0
     LNSTOP=1
     IREPET=1
     ALPHA = 1.0D00
     PNORM=1.0D00
     JNRST=0
     CYCMX=0.D0
     COS=0.0D00
     TOTIME=0.D0
     NCOUNT=1
     IF( SADDLE) THEN

   WE DON'T NEED HIGH PRECISION DURING A SADDLE-POINT CALCULATION.

         IF(NVAR.GT.0)GNORM=SQRT(DOT(GRAD,GRAD,NVAR))
         IF(GNORM.GT.1.D0) TOLERG=TOLRG*GNORM
     WRITE(6,'('' GRADIENT CRITERION IN FLEPO ='',F12.5)')TOLERG
     ENDIF
     IF (RESTRT .AND. ICALCN .NE. NUMCAL) THEN
         MDFP(9)=0
         CALL DFPSAV(TOTIME,XPARAM,GD,XLAST,FUNCT1,MDFP,XDFP)
     ELSE

 CALCULATE THE VALUE OF THE FUNCTION -> FUNCT1, AND GRADIENTS -> GRAD.
 NORMAL SET-UP OF FUNCT1 AND GRAD, DONE ONCE ONLY.

         CALL COMPFG (XPARAM, .TRUE., FUNCT1,.TRUE.,GRAD,.TRUE.)
         DO 641 I=1,NVAR
 641     GD(I)=GRAD(I)
     ENDIF
     ICALCN=NUMCAL
     IF(NVAR.NE.0)GNORM=SQRT(DOT(GRAD,GRAD,NVAR))
     IFLEPO=1
     IF(INDEX(KEYWRD,'1SCF') .NE. 0) RETURN
     IFLEPO=2
     IF(GNORM.LT.MAX(GNLIM,TOLERG).OR.NVAR.EQ.0) THEN
     IF(RESTRT)
    + CALL COMPFG (XPARAM, .TRUE., FUNCT1,.TRUE.,GRAD,.TRUE.)
     RETURN
     ENDIF
     TX1 =  SECOND()
     TLEFT=TLEFT-TX1+TX2
     *
     START OF EACH ITERATION CYCLE ...
     *

     RESET=.FALSE.
     GOTO 191
 190 CONTINUE
     IF(COS .LT. RST) THEN
         DO 192 I=1,NVAR
 192     GD(I)=0.5D0
     ENDIF
 191 CONTINUE
     GNORM=SQRT(DOT(GRAD,GRAD,NVAR))
     JCYC=JCYC+1
     JNRST=JNRST+1
     IF (LNSTOP.NE.1 .AND. COS.GT.RST .AND. JNRST.LT.NRST) GOTO 300

     *
     RESTART SECTION
     *

 220 CONTINUE
     RESET=.TRUE.
     DO 230 I=1,NVAR
        XD(I)=XPARAM(I)-SIGN(DEL,GRAD(I))
 230 CONTINUE

 THIS CALL OF COMPFG IS USED TO CALCULATE THE SECOND-ORDER MATRIX IN H
 IF THE NEW POINT HAPPENS TO IMPROVE THE RESULT, THEN IT IS KEPT.
 OTHERWISE IT IS SCRAPPED, BUT STILL THE SECOND-ORDER MATRIX IS O.K.

     CALL COMPFG (XD, .TRUE., FUNCT2,.TRUE.,GD,.TRUE.)
     IF(.NOT. GEOOK .AND. SQRT(DOT(GD,GD,NVAR))/GNORM.GT.10.
    + AND.GNORM.GT.20)THEN

    THE GEOMETRY IS BADLY SPECIFIED IN THAT MINOR CHANGES IN INTERNAL
    COORDINATES LEAD TO LARGE CHANGES IN CARTESIAN COORDINATES, AND THESE
    LARGE CHANGES ARE BETWEEN PAIRS OF ATOMS THAT ARE CHEMICALLY BONDED
    TOGETHER.
     WRITE(6,'('' GRADIENTS OF OLD GEOMETRY, GNORM='',F13.6)')GNORM
     WRITE(6,'(6F12.6)')(GRAD(I),I=1,NVAR)
     GDNORM=SQRT(DOT(GD,GD,NVAR))
     WRITE(6,'('' GRADIENTS OF NEW GEOMETRY, GNORM='',F13.6)')GDNORM
     WRITE(6,'(6F12.6)')(GD(I),I=1,NVAR)
     WRITE(6,'(///20X,''CALCULATION ABANDONED AT THIS POINT!'')')
     WRITE(6,'(//10X,'' SMALL CHANGES IN INTERNAL COORDINATES ARE'',/
    +10X,'' CAUSING A LARGE CHANGE IN THE DISTANCE BETWEEN'',/
    110X,'' CHEMICALLY-BOUND ATOMS. THE GEOMETRY OPTIMISATION'',/
    210X,'' PROCEDURE WOULD LIKELY PRODUCE INCORRECT RESULTS'')')
     CALL GEOUT
     STOP
     ENDIF
     NCOUNT=NCOUNT+1
     DO 240 I=1,IHDIM
 240   HESINV(I)=0.0D00
     DO 270 I=1,NVAR
        II=I+NVAR*(I-1)-((I*(I-1))/2)
        GGGGG=GRAD(I)-GD(I)
        IF (ABS(GGGGG).LT.1.D-12) GO TO 250
        GGD=ABS(GRAD(I))
        IF (FUNCT2.LT.FUNCT1) GGD=ABS(GD(I))
        HESINV(II)=SIGN(DEL,GRAD(I))/GGGGG
        IF (HESINV(II).LT.0.0D00.AND.GGD.LT.1.D-12) GO TO 250
        IF (HESINV(II).LT.0.0D00) HESINV(II)=(TDEL*DEL)/GGD
        GO TO 260
 250    HESINV(II)=0.01D00
 260    CONTINUE
        IF (GGD.LT.1.D-12) GGD=1.D-12
        PMSTEP=ABS(PMSTE/GGD)
        IF (HESINV(II).GT.PMSTEP) HESINV(II)=PMSTEP
 270 CONTINUE
     JNRST=0
     IF(JCYC.LT.2) COSINE=1.D0
     IF(FUNCT2 .GE. FUNCT1) THEN
         IF(PRINT)WRITE (6,740) FUNCT1,FUNCT2
 740     FORMAT ('      FUNCTION VALUE=',F15.8,5X,
    1 'WILL NOT BE REPLACED BY VALUE=',F15.8,5X,
    1 'CALCULATED BY RESTART PROCEDURE',/)
         CALL COMPFG (XPARAM, .TRUE., FUNCT1,.TRUE.,GD,.FALSE.)
         COSINE=1.D0
         ELSE
         IF( PRINT ) WRITE (6,750) FUNCT1,FUNCT2
 750     FORMAT ('      FUNCTION VALUE=',F15.8,5X,
    +'IS BEING REPLACED BY VALUE=',F15.8,5X,
    +'FOUND IN RESTART PROCEDURE',/,6X,
    +'THE CORRESPONDING X VALUES AND GRADIENTS ARE ALSO BEING REPLACED'
    +,/)
         FUNCT1=FUNCT2
         GNORM=0.0D00
         DO 280 I=1,NVAR
            XPARAM(I)=XD(I)
            GRAD(I)=GD(I)
 280     GNORM=GNORM+GRAD(I)**2
         GNORM=SQRT(GNORM)
     ENDIF
     GO TO 340

     *
     UPDATE VARIABLE-METRIC MATRIX
     *

 300 SY=0.0D00
     YHY=0.0D00
     DO 320 I=1,NVAR
        S=0.0D00
        DO 310 K=1,NVAR
           IK=I+NVAR*(K-1)-((K*(K-1))/2)
           IF (K.GT.I) IK=K+NVAR*(I-1)-((I*(I-1))/2)
 310    S=S+HESINV(IK)*(GRAD(K)-GLAST(K))
        GG(I)=S
        Y=GRAD(I)-GLAST(I)
        YHY=YHY+GG(I)*Y
 320 SY=SY+(XPARAM(I)-XLAST(I))*Y
     DO 330 I=1,NVAR
        Y=XPARAM(I)-XLAST(I)
     DO 330 K=I,NVAR
        IK=K+NVAR*(I-1)-((I*(I-1))/2)
        HESINV(IK)=HESINV(IK)+Y*(XPARAM(K)-XLAST(K))
    +              /SY-GG(I)*GG(K)/YHY
 330 CONTINUE

     *
     ESTABLISH NEW SEARCH DIRECTION
     *
 340 PNLAST=PNORM
     PNORM=0.0D00
     DOTT=0.0D00
     DO 360 K=1,NVAR
        S=0.0D00
        DO 350 I=1,NVAR
           IK=I+NVAR*(K-1)-((K*(K-1))/2)
           IF (K.GT.I) IK=K+NVAR*(I-1)-((I*(I-1))/2)
           S=S-HESINV(IK)*GRAD(I)
 350    CONTINUE
        PVECT(K)=S
        PNORM=PNORM+PVECT(K)**2
 360 DOTT=DOTT+PVECT(K)*GRAD(K)
     PNORM=SQRT(PNORM)
     COS=-DOTT/(PNORM*GNORM)
     IF (JNRST.EQ.0) GO TO 380
     IF (COS.LE.CNCADD.AND.YEAD.GT.1.0D00) GO TO 370
     IF (COS.LE.RST) GO TO 370
     GO TO 380
 370 PNORM=PNLAST
     IF( PRINT )WRITE (6,760) COS
 760 FORMAT (//,5X, 10HSINCE COS=,F9.3,5X, 38HTHE PROGRAM WILL GO TO RE
    1START SECTION,/)
     GO TO 220
 380 CONTINUE
     IF ( PRINT ) WRITE (6,870) JCYC,FUNCT1
 870 FORMAT (1H , 25HAT THE BEGINNING OF CYCLE,I5, 24H  THE FUNCTION VA
    1LUE IS ,F13.6/, 26H  THE CURRENT POINT IS ...)
     IF(PRINT)WRITE (6,930) GNORM,COS
 930 FORMAT ( 18H  GRADIENT NORM = ,F10.4/, 17H  ANGLE COSINE = ,F10.4)
     NTO6=NVAR/6
     NREM6=NVAR-NTO6*6
     IINC1=-5
     IF (NTO6.LT.1.OR. .NOT. PRINT) GO TO 420
     DO 410 I=1,NTO6
        WRITE (6,'(/)')
        IINC1=IINC1+6
        IINC2=IINC1+5
        WRITE (6,890) (J,J=IINC1,IINC2)
        WRITE (6,900) (XPARAM(J),J=IINC1,IINC2)
        WRITE (6,910) (GRAD(J),J=IINC1,IINC2)
        WRITE (6,920) (PVECT(J),J=IINC1,IINC2)
 890 FORMAT (1H ,3X,  1HI,9X,I3,9(8X,I3))
 900 FORMAT (1H ,1X, 'XPARAM(I)',1X,F9.4,2X,9(F9.4,2X))
 910 FORMAT (1H ,1X, 'GRAD  (I)',F10.4,1X,9(F10.4,1X))
 920 FORMAT (1H ,1X, 'PVECT (I)',1X,F9.4,2X,9(F9.4,2X))
 410 CONTINUE
 420 CONTINUE
     IF (NREM6.LT.1.OR. .NOT. PRINT) GO TO 430
     WRITE (6,'(/)')
     IINC1=IINC1+6
     IINC2=IINC1+(NREM6-1)
     WRITE (6,890) (J,J=IINC1,IINC2)
     WRITE (6,900) (XPARAM(J),J=IINC1,IINC2)
     WRITE (6,910) (GRAD(J),J=IINC1,IINC2)
     WRITE (6,920) (PVECT(J),J=IINC1,IINC2)
 430 CONTINUE
     FI=FUNCT1
     LNSTOP=0
     ALPHA=ALPHA*PNLAST/PNORM
     DO 440 I=1,NVAR
        GLAST(I)=GRAD(I)
 440 XLAST(I)=XPARAM(I)
     IF (JNRST.EQ.0) ALPHA=1.0D00
     YEAD=ABS(ALPHA*DOTT)
     IF(PRINT)WRITE (6,780) YEAD
 780 FORMAT (1H , 13H -ALPHA.P.G =,F18.6,/)
     IF (JNRST.NE.0.AND.YEAD.LT.EYEAD) THEN
         IF(MINPRT)WRITE (6,830)
 830     FORMAT(//,10X,'HERBERTS TEST SATISFIED - GEOMETRY OPTIMISED')

   FLEPO IS ENDING PROPERLY. THIS IS IMMEDIATELY BEFORE THE RETURN.

         LAST=1
         CALL COMPFG (XPARAM, .TRUE., FUNCT,.TRUE.,GRAD,.FALSE.)
         IFLEPO=3
         RETURN
     ENDIF
     SMVAL=FUNCT1
     CALL LINMIN(XPARAM,ALPHA,PVECT,NVAR,FUNCT1,OKF,OKC)
     NCOUNT=NCOUNT+1
     IF ( .NOT. OKF) THEN
         LNSTOP = 1
         IF(MINPRT)WRITE (6,800)
 800     FORMAT (1H ,///,20X, 'NO POINT LOWER IN ENERGY ',
    +    'THAN THE STARTING POINT COULD BE FOUND ',
    1    'IN THE LINE MINIMIZATION')
         FUNCT1=SMVAL
         DO 480 I=1,NVAR
            GRAD(I)=GLAST(I)
            XPARAM(I)=XLAST(I)
 480     CONTINUE
         IF (JNRST.EQ.0)THEN
             WRITE (6,820)
 820        FORMAT (1H ,//,20X, 'SINCE COS WAS JUST RESET,THE SEARCH ',
    +        'IS BEING ENDED')

             FLEPO IS ENDING BADLY. THIS IS IMMEDIATELY BEFORE THE RETURN.

             LAST=1
             CALL COMPFG (XPARAM, .TRUE., FUNCT,.TRUE.,GRAD,.FALSE.)
             IFLEPO=4
             RETURN
         ENDIF
         IF(PRINT)WRITE (6,810)
 810     FORMAT (1H ,20X, 'COS WILL BE RESET AND ANOTHER '
    +    ,'ATTEMPT MADE')
         COS=0.0D00
         GO TO 670
     ENDIF
   WE WANT ACCURATE DERIVATIVES AT THIS POINT

   LINMIN DOES NOT GENERATE ANY DERIVATIVES, THEREFORE COMPFG MUST BE
   CALLED TO END THE SEARCH

          IF(RESET) THEN
          DO 642 J=1,NVAR
 642          GRAD(J)=0.D0
          RESET=.FALSE.
          ENDIF
     CALL COMPFG (XPARAM, .TRUE., FUNCT1,.TRUE.,GRAD,.TRUE.)
     IF (.NOT. OKC .AND. MINPRT)WRITE (6,940) JCYC
 940 FORMAT ( 23H0LINMIN FAILED AT CYCLE,I5/,  1H0)
     XN=0.0D00
     DO 510 K=1,NVAR
 510   XN=XN+XPARAM(K)**2
     XN=SQRT(XN)
     TX=ABS(ALPHA*PNORM)
     IF (XN.NE.0.0D00) TX=TX/XN
     TF=ABS(FI-FUNCT1)
#      IF (FUNCT1.NE.0.0D00) TF=TF/ABS(FUNCT1)
     IF (PRINT) WRITE (6,950) NCOUNT,TX,TF,GNORM
 950 FORMAT ( 23H  TERMINATION TESTS ...,/, 24H     NUMBER OF COUNTS =
    1,I5/, 28H     RELATIVE CHANGE IN X = ,F13.6/, 28H     RELATIVE CHA
    2NGE IN F = ,F13.6/, '     GRADIENT NORM        = ',F13.6,//)
 530 IF (NCOUNT.GE.MAXEND) THEN
         WRITE (6,960)
 960     FORMAT ( 33H0TERMINATION FROM TOO MANY COUNTS)
         LAST=1
         CALL COMPFG (XPARAM, .TRUE., FUNCT,.TRUE.,GRAD,.FALSE.)
         IFLEPO=5
         RETURN
     ENDIF
     IF (TX.LE.TOLERX) THEN
         IF(MINPRT) WRITE (6,970)
 970     FORMAT ( 20H0TEST ON X SATISFIED)
         GO TO 610
     ENDIF
     IF (TF.LE.TOLERF) THEN
         IF(MINPRT) WRITE (6,980)
 980     FORMAT (' HEAT OF FORMATION TEST SATISFIED')
         GO TO 610
     ENDIF
     IF (GNORM.LE.TOLERG*ROOTV) THEN
         IF(MINPRT) WRITE (6,990)
 990     FORMAT ( 27H0TEST ON GRADIENT SATISFIED)
         GOTO 610
     ENDIF
     GOTO 670
 610 DO 620 I=1,NVAR
       IF (ABS(GRAD(I)).GT.TOLERG)THEN
          IREPET=IREPET+1
          IF (IREPET.GT.1) GO TO 640
          FREPF=FUNCT1
          COS=0.0D00
 640      CONTINUE
          IF(MINPRT) WRITE (6,1000)TOLERG
1000      FORMAT (20X,'HOWEVER, A COMPONENT OF GRADIENT IS ',
    +     'LARGER THAN',F6.2 ,/)
          IF (ABS(FUNCT1-FREPF).GT.EINC) IREPET=0
          IF (IREPET.GT.IGG1) THEN
              WRITE (6,840)IGG1,EINC
 840 FORMAT (10X,' THERE HAVE BEEN',I2,' ATTEMPTS TO REDUCE THE ',
    +' GRADIENT.',/10X,' DURING THESE ATTEMPTS THE ENERGY DROPPED',
    +' BY LESS THAN',F4.1,' KCAL/MOLE',/
    +10X,' FURTHER CALCULATION IS NOT JUSTIFIED AT THIS TIME.',/
    +10X,' TO CONTINUE, START AGAIN WITH THE WORD "PRECISE"' )
              LAST=1
              CALL COMPFG (XPARAM, .TRUE., FUNCT,.TRUE.,GRAD,.FALSE.)
              IFLEPO=8
              RETURN
          ELSE
          GOTO 670
          ENDIF
       ENDIF
 620 CONTINUE
     IF(MINPRT) WRITE (6,860)
 860 FORMAT ( 23H PETERS TEST SATISFIED )
     LAST=1
     CALL COMPFG (XPARAM, .TRUE., FUNCT,.TRUE.,GRAD,.FALSE.)
     IFLEPO=6
     RETURN

   ALL TESTS HAVE FAILED, WE NEED TO DO ANOTHER CYCLE.

 670 CONTINUE
     BSMVF=ABS(SMVAL-FUNCT1)
     IF (BSMVF.GT.10.D00) COS = 0.0D00
     DEL=0.002D00
     IF (BSMVF.GT.1.0D00) DEL=DELL/2.0D00
     IF (BSMVF.GT.5.0D00) DEL=DELL
     TX2 = SECOND ()
     TCYCLE=TX2-TX1
     TX1=TX2

 END OF ITERATION LOOP, EVERYTHING IS STILL O.K. SO GO TO
 NEXT ITERATION, IF THERE IS ENOUGH TIME LEFT.

     IF(TCYCLE.LT.100000.D0)CYCMX=MAX(CYCMX,TCYCLE)
     TLEFT=TLEFT-TCYCLE
     IF(TLEFT.LT.0)TLEFT=-0.1D0
     IF(TCYCLE.GT.1.D5)TCYCLE=0.D0
     IF(MINPRT) WRITE(6,3141)JCYC,TCYCLE,TLEFT,GNORM,FUNCT1
3141 FORMAT(' CYCLE:',I3,' TIME:',F8.2,' TIME LEFT:',F9.2,
    +' GRADIENT:',F10.3,' HEAT:',F10.5)
     IF (TLEFT.GT.SFACT*CYCMX) GO TO 190
     WRITE(6,700)
 700 FORMAT (20X, 42HTHERE IS NOT ENOUGH TIME FOR ANOTHER CYCLE,/,30X,
    118HNOW GOING TO FINAL)
     MDFP(9)=1
     CALL DFPSAV(TOTIME,XPARAM,GD,XLAST,FUNCT1,MDFP,XDFP)

     END


module slf_cgs

  use iso_fortran_env, only: r64 => real64
  implicit none

  real(r64), parameter, private :: pi = 4*atan(real(1,r64))

  real(r64), parameter :: &
    cgs_boltz = 1.3806581212d-16,     &
    cgs_c = 2.99792458d10, &
    cgs_h = 6.62607554040d-27, &
    cgs_graw = 6.67259858585d-8, &
    cgs_mel = 9.10938975454d-28,    &
    cgs_hbar= cgs_h / (2*pi), &
    cgs_stef = 2 * pi**5 * cgs_boltz**4 / ( 15 * cgs_h**3 * cgs_c**2 ), &
    cgs_a = 4 * cgs_stef / cgs_c, &
    cgs_alpha = 1 / 137.036d0, &
    cgs_qel = sqrt( cgs_alpha * cgs_hbar * cgs_c ), &
    cgs_thomson = 8 * pi / 3 * cgs_qel**4 / ( cgs_c**4 * cgs_mel**2 ), &
    cgs_elrad = cgs_qel**2 / ( cgs_c**2 * cgs_mel ), &
    cgs_mhydr = 1.6733d-24,    &
    cgs_kapes_hydrogen = cgs_thomson / cgs_mhydr, &
    cgs_k = cgs_boltz,   &
    cgs_k_over_mh = cgs_boltz / cgs_mhydr , &
    cgs_mh_over_k = cgs_mhydr / cgs_boltz, &
    cgs_k_over_mec = cgs_boltz / ( cgs_mel * cgs_c ), &
    cgs_mec_over_k = ( cgs_mel * cgs_c ) / cgs_boltz, &
    cgs_k_over_mec2 = cgs_boltz / ( cgs_mel * cgs_c**2 ), &
    cgs_mec2_over_k = ( cgs_mel * cgs_c**2 ) / cgs_boltz, &
    cgs_msun = 1.98855d33, &
    cgs_lsun = 3.828d33,     &
    cgs_kapes = cgs_kapes_hydrogen * 0.85

  real(r64), parameter :: &
    keV_in_erg = 1.6021772d-9, &
    keV_in_kelvin = cgs_boltz / keV_in_erg,   &
    angstr_keV = 1e8 * cgs_h * cgs_c / keV_in_erg

  ! UWAGA: nie uzywac!!!!
  real(r64), parameter ::  &
    sol_mass = 1.98855d33, sol_lum = 3.828d33,              &
    sol_rschw = 2 * cgs_graw * sol_mass / cgs_c**2,         &
    sol_mdot_crit = 4 * pi * (cgs_graw * sol_mass) / (cgs_c * cgs_kapes), &
    sol_mdot_edd = 12 * sol_mdot_crit,                      &
    sol_facc_edd = 3 * cgs_graw * sol_mass * sol_mdot_edd   &
              / ( 8 * pi * sol_rschw**3 ),            &
    sol_omega = sqrt( cgs_graw * sol_mass / sol_rschw**3 )

end module


      SUBROUTINE PSVFCJ(DTT,TTHETA,SIG,GAM,SHL,PRFUNC,
     1  DPRDT,SIGPART,GAMPART,SHLPART)

!PURPOSE: Compute function & derivatives for Pseudovoigt profile
!   [W.I.F.David (1986), J. Appl. Cryst. 19, 63-64 &
!    P. Thompson, D.E. Cox & J.B. Hastings (1987) J. Appl. Cryst.,20,79-83.]
! Finger-Cox-Jephcoat (FCJ94) asymmetry correction
!   [L.W. Finger, D.E. Cox & A.P. Jephcoat (1994) J. Appl. Cryst.,27,892-900.]
! coded 11/95 by B. H. Toby (NIST). revised version
! parameterized as asym=S/L+H/L

      INCLUDE       '../INCLDS/COPYRIGT.FOR'

!CALLING ARGUMENTS:

      REAL*4        DTT                 !delta 2-theta in centidegrees
      REAL*4        TTHETA              !2-theta in centidegrees
      REAL*4        SIG,GAM
      REAL*4        SHL                 !S/L + H/L
      REAL*4        PRFUNC
      REAL*4        DPRDT
      REAL*4        SIGPART,GAMPART
      REAL*4        SHLPART

!INCLUDE STATEMENTS:
      real*4 sind,cosd,tand,acosd

!LOCAL VARIABLES:

      REAL*4        R                   ! pseudo-voight intensity
      REAL*4        DRDT                ! deriv R w/r theta
      REAL*4        DRDS                ! deriv R w/r sig
      REAL*4        DRDG                ! deriv R w/r gam
      REAL*4        F
      REAL*4        G
      REAL*4        DFDA
      REAL*4        DGDA
      REAL*4        DYDA
      REAL*4        SIN2THETA2          ! sin(2theta)**2
      REAL*4        COS2THETA           ! cos(2theta)
      REAL*4        SIN2THETA           ! sin(2THETA)
      REAL*4        SINDELTA            ! sin(Delta)
      REAL*4        COSDELTA            ! cos(Delta)
      REAL*4        RCOSDELTA           ! 1/cos(Delta)
      REAL*4        TANDELTA            ! tan(Delta)
      REAL*4        COSDELTA2           ! cos(Delta)**2
      REAL*4        A                   ! asym1 [coff(7)]
      REAL*4        APB                 ! (A+B)
      REAL*4        APB2                ! (A+B)**2
      REAL*4        TTHETAD             ! Two Theta in degrees

! Intermediate variables

      REAL*4        RSUMWG2             !      1.0/(sum of w G)**2
      REAL*4        SUMWG               !      sum of w G
      REAL*4        WG                  !      w G
      REAL*4        RSUMWG              !      1.0/sum of w G
      REAL*4        SUMWRG              !      sum of w G
      REAL*4        SUMWDGDA            !      sum of w dGdA
      REAL*4        SUMWRDGDA           !      sum of w R dGdA
      REAL*4        SUMWGDRD2T          !      sum of w G dRd(2theta)
      REAL*4        SUMWGDRDSIG         !      sum of w G dRdp(n)
      REAL*4        SUMWGDRDGAM         !      sum of w G dRdp(n)
      REAL*4        SUMWGDRDA
      REAL*4        EMIN                ! 2phi minimum
      REAL*4        EINFL               ! 2phi of inflection point
      REAL*4        DEMINDA             ! Derivative of Emin wrt A
      REAL*4        DELTA               ! Angle of integration for convolution
      REAL*4        DDELTADA
      REAL*4        TMP,TMP1,TMP2       ! intermediates
      INTEGER*4     I,K,IT              ! Miscellaneous loop variables
c
c       Local Variables for Gaussian Integration
c
      INTEGER*4     NGT                 !number of terms in Gaussian quadrature
      INTEGER*4     NUMTAB              ! number of pre-computed Gaussian tables
      parameter      (numtab=34)
      INTEGER*4     NTERMS(NUMTAB)      ! number of terms in each table - must be even
      INTEGER*4     FSTTERM(NUMTAB)     ! location of 1st term: N.B. N/2 terms
      LOGICAL*4     CALCLFG(NUMTAB)     ! true if table has previously been calculated
      INTEGER*4     ARRAYNUM            ! number of selected array
      INTEGER*4     ARRAYSIZE           ! size of complete array
      parameter      (arraysize=1670)
      REAL*4        XP(ARRAYSIZE)       !Gaussian abscissas
      REAL*4        WP(ARRAYSIZE)       !Gaussian weights
      REAL*4        XPT(400)            !temporary Gaussian abscissas
      REAL*4        WPT(400)            !temporary Gaussian weights
      REAL*4        STOFW
      PARAMETER (STOFW=2.35482005)
      REAL*4        TODEG
      PARAMETER (todeg=57.2957795)
      save      calclfg,xp,wp          !Values to be saved across calls

!FUNCTION DEFINITIONS:

!DATA STATEMENTS:

      DATA      NTERMS                ! number of terms in each table - must be even
     1  /2,4,6,8,10,12,14,16,18,20,22,24,26,28,30,40,50,60,70,80,90	! Numbers of terms changed May 2004
     2   ,100,110,120,140,160,180,200,220,240,260,280,300,400/
C       note that nterms determines both arraysize and fstterm
      DATA      FSTTERM                ! loc. of 1st term: N.B. N/2 terms are saved
     1  /0,1,3,6,10,15,21,28,36,45,55,66,78,91,105,120,140,165,195,230, !FSTERM(1) should be 0 - indexing starts at 1+this number!
     2  270,315,365,420,480,550,630,720,820,930,1050,1180,1320,1470/
      DATA      calclfg/numtab*.false./ ! true if table entry has been calculated

!CODE:

c
C f(2theta) intermediates
c
      TTHETAD = 0.01 * TTHETA
      SIN2THETA = SIND(TTHETAD)
      cos2THETA = COSD(TTHETAD)
      sin2theta2 = sin2THETA * sin2THETA
      cos2THETA2 = cos2THETA * cos2THETA
c
C Asymmetry terms
c
      A = SHL/2.            ! A = S/L in FCJ
      ApB = SHL
      ApB2 = ApB*ApB
c
C handle the case where there is asymmetry
c
      IF (A .ne. 0.0) then
        Einfl = Acosd(cos2THETA)
        tmp2 = 1.0 + ApB2
        tmp = SQRT(tmp2)*cos2THETA
        if (abs(tmp) .le. 1.0) then
          Emin = Acosd(tmp)
          tmp1 = tmp2*(1.0 - tmp2*(1.0-sin2THETA2))
        else
C            print *,'tmp > 1.0'
          tmp1 = 0.0
          if (tmp .gt. 0.0) then
            Emin = 0.0
          else
            Emin = 180.0
          endif
        endif
        if (tmp1 .gt. 0 .and. abs(tmp) .le. 1.0) then
          dEmindA = -ApB*cos2THETA/SQRT(tmp1)
        ELSE
          dEmindA = 0.0
        ENDIF

c
c Compute Gaussian Quadrature interval
C Note that the number of points must be large enough so that the
c interval between 2phi(min) and 2theta must be divided into steps no
c larger than 0.005 degrees.  LWF  8/10/95
c
c Determine which Gauss-Legendre Table to use
c
        arraynum = 1
c
c Calculate desired number of intervals
c
        tmp = abs(TTHETAD - emin)               ! tmp in degrees
        IF ( GAM.LE.0.0 ) THEN
          K = INT(TMP*200.0)                    !RVD formulation
        ELSE
          k = int(300.0*tmp/GAM)                !New formulation of May 2004
        END IF
c
C Find the next largest set
c
        do while (arraynum .lt. numtab .and. k.gt.nterms(arraynum))
          arraynum = arraynum + 1
        enddo
        ngt = nterms(arraynum)
c
C calculate the terms, if they have not been used before
c
        if (.not. calclfg(arraynum)) then
          calclfg(arraynum) = .true.
          call gauleg(-1.,1.,xpt,wpt,ngt)
          it = fstterm(arraynum)-ngt/2
c
C copy the ngt/2 terms from our working array to the stored array
c
          do k=ngt/2+1,ngt
            xp(k+it) = xpt(k)
            wp(k+it) = wpt(k)
          enddo
        endif
        sumWG = 0.
        sumWRG = 0.
        sumWdGdA = 0.
        sumWRdGdA = 0.
        sumWGdRd2t = 0.
        sumWGdRdsig = 0.
        sumWGdRdgam = 0.
        sumWGdRdA = 0.
        sumWGdRdB = 0.
c
c Compute Convolution integral for 2phi(min) <= delta <= 2theta
c
        it = fstterm(arraynum)-ngt/2
        do k=ngt/2+1,ngt
          delta = emin + (TTHETAD - emin) * xp(k+it) ! Delta in degrees
          CALL PSVOIGT(DTT+TTHETA-delta*100.,SIG,GAM,R,dRdT,dRdS,dRdG)
          dDELTAdA = (1. - xp(k+it))*dEmindA ! N. B. symm w/r A,B
          sinDELTA = sind(Delta)
          cosDELTA = cosd(Delta)
          RcosDELTA = 1. / cosDELTA
          tanDELTA = tand(Delta)
          cosDELTA2 = cosDELTA*cosDELTA
          if ( ttheta.le.4500.0 .or. ttheta.gt.13500.0 ) then
            tmp = sin2THETA2-sinDelta**2
          else
            tmp = cosDELTA2-cos2THETA2
          end if
          if (tmp .gt. 0) then
            tmp1 = 1.0/SQRT(tmp)
            F = abs(cos2THETA) * tmp1
            dFdA = cosDELTA*cos2THETA*sinDELTA*dDELTAdA*tmp1**3
          else
            F = 1.0
            dFdA = 0.0
          endif
c
c Calculate G(Delta,2theta) [G = W /(h cos(delta) ] [ FCJ eq. 7(a) and 7(b) ]
c
          if ( ttheta.gt.9000.0 ) then                  !are you kidding!! this worked
!          if(abs(delta-emin) .gt. abs(einfl-emin))then
              G = 2.0*A*F*RcosDELTA
              dGdA = 2.0*A*RcosDELTA*(dFdA + F*tanDELTA*dDELTAdA)
          else
            G = (-1.0 + ApB*F) * RcosDELTA
            dGdA = RcosDELTA*(F - tanDELTA*dDELTAdA
     1             + ApB*F*tanDELTA*dDELTAdA + ApB*dFdA)
          endif

          WG = wp(k+it) * G
          sumWG = sumWG + WG
          sumWRG = sumWRG + WG * R
          sumWdGdA = sumWdGdA + wp(k+it) * dGdA
          sumWRdGdA = sumWRdGdA + wp(k+it) * R * dGdA
          sumWGdRd2t = sumWGdRd2t + WG * dRdT ! N.B. 1/centidegrees
          sumWGdRdsig = sumWGdRdsig + WG * dRdS
          sumWGdRdgam = sumWGdRdgam + WG * dRdG
          sumWGdRdA = sumWGdRdA + WG * dRdT * dDELTAdA ! N. B. symm w/r A,B
        enddo
        RsumWG = 1.0/sumWG
        RsumWG2 = RsumWG * RsumWG
        PRFUNC = sumWRG * RsumWG

        dydA = (-(sumWRG*sumWdGdA) +
     1    sumWG*(sumWRdGdA- 100.0 * todeg * sumWGdRdA)) * RsumWG2
        sigpart = sumWGdRdsig * RsumWG
        gampart = sumWGdRdgam * RsumWG
        DPRDT = -SumWGdRd2T * RsumWG
      else
c
C no asymmetry -- nice and simple!
c
        CALL PSVOIGT(DTT,SIG,GAM,R,dRdT,dRdS,dRdG)
        PRFUNC = R
        dydA = 0.004 * sign(1.0,TTHETA - DTT)
        sigpart = dRdS
        gampart = dRdG
        DPRDT = -dRdT
      END IF
      SHLPART = DYDA

      RETURN
      END


subroutine hus_vertical_interpolation(hus_on_model_level,pres, &
	pressure_full_level,m,n,o,p,req,hus_on_press_level)
implicit none
integer :: m,n,o,p,req
integer :: x,y,s,t,plev
double precision :: pres(req),hus_on_model_level(m,n,o,p)
double precision :: pressure_full_level(m,n,o,p)
double precision :: delta_hus,delta_p,grad_hus_p,diff_p
double precision, intent(out) :: hus_on_press_level(m,n,req,p)
real :: arg = -1.0,NaN
NaN= sqrt(arg)
do plev=1,req
 do t=1,p
  do x=1,m
   do y=1,n
    do s=1,o
!above uppest level
    if(pres(plev) .LT. pressure_full_level(x,y,1,t)) then
     hus_on_press_level(x,y,plev,t) = NaN
    end if
! in between levels
    if(pres(plev) .GE. pressure_full_level(x,y,s,t) .AND. pres(plev) .LE. &
     pressure_full_level(x,y,s+1,t) ) then
     delta_hus = hus_on_model_level(x,y,s,t) - hus_on_model_level(x,y,s+1,t)
     delta_p = log(pressure_full_level(x,y,s,t))&
     - log(pressure_full_level(x,y,s+1,t))
     grad_hus_p = delta_hus /delta_p
     diff_p = log(pres(plev)) - log(pressure_full_level(x,y,s,t))
     hus_on_press_level(x,y,plev,t) = hus_on_model_level(x,y,s,t)&
     + grad_hus_p * diff_p
    end if
! extrapolation below the ground
    if(pres(plev) .GT. pressure_full_level(x,y,o,t)) then
     hus_on_press_level(x,y,plev,t) = hus_on_model_level(x,y,o,t)
    end if
    end do
   end do
  end do
 end do
end do
end subroutine hus_vertical_interpolation


      SUBROUTINE AB05RD( FBTYPE, JOBD, N, M, P, MV, PZ, ALPHA, BETA, A,
     $                   LDA, B, LDB, C, LDC, D, LDD, F, LDF, K, LDK,
     $                   G, LDG, H, LDH, RCOND, BC, LDBC, CC, LDCC,
     $                   DC, LDDC, IWORK, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To construct for a given state space system (A,B,C,D) the closed-
C     loop system (Ac,Bc,Cc,Dc) corresponding to the mixed output and
C     state feedback control law
C
C          u = alpha*F*y + beta*K*x + G*v
C          z = H*y.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     FBTYPE  CHARACTER*1
C             Specifies the type of the feedback law as follows:
C             = 'I':  Unitary output feedback (F = I);
C             = 'O':  General output feedback.
C
C     JOBD    CHARACTER*1
C             Specifies whether or not a non-zero matrix D appears
C             in the given state space model:
C             = 'D':  D is present;
C             = 'Z':  D is assumed a zero matrix.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The dimension of state vector x, i.e. the order of the
C             matrix A, the number of rows of B and the number of
C             columns of C.  N >= 0.
C
C     M       (input) INTEGER
C             The dimension of input vector u, i.e. the number of
C             columns of matrices B and D, and the number of rows of F.
C             M >= 0.
C
C     P       (input) INTEGER
C             The dimension of output vector y, i.e. the number of rows
C             of matrices C and D, and the number of columns of F.
C             P >= 0 and P = M if FBTYPE = 'I'.
C
C     MV      (input) INTEGER
C             The dimension of the new input vector v, i.e. the number
C             of columns of matrix G.  MV >= 0.
C
C     PZ      (input) INTEGER.
C             The dimension of the new output vector z, i.e. the number
C             of rows of matrix H.  PZ >= 0.
C
C     ALPHA   (input) DOUBLE PRECISION
C             The coefficient alpha in the output feedback law.
C
C     BETA    (input) DOUBLE PRECISION.
C             The coefficient beta in the state feedback law.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the system state transition matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the state matrix Ac of the closed-loop system.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the system input matrix B.
C             On exit, the leading N-by-M part of this array contains
C             the intermediary input matrix B1 (see METHOD).
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the system output matrix C.
C             On exit, the leading P-by-N part of this array contains
C             the intermediary output matrix C1+BETA*D1*K (see METHOD).
C
C     LDC     INTEGER
C             The leading dimension of array C.
C             LDC >= MAX(1,P) if N > 0.
C             LDC >= 1 if N = 0.
C
C     D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
C             On entry, if JOBD = 'D', the leading P-by-M part of this
C             array must contain the system direct input/output
C             transmission matrix D.
C             On exit, the leading P-by-M part of this array contains
C             the intermediary direct input/output transmission matrix
C             D1 (see METHOD).
C             The array D is not referenced if JOBD = 'Z'.
C
C     LDD     INTEGER
C             The leading dimension of array D.
C             LDD >= MAX(1,P) if JOBD = 'D'.
C             LDD >= 1 if JOBD = 'Z'.
C
C     F       (input) DOUBLE PRECISION array, dimension (LDF,P)
C             If FBTYPE = 'O', the leading M-by-P part of this array
C             must contain the output feedback matrix F.
C             If FBTYPE = 'I', then the feedback matrix is assumed to be
C             an M x M order identity matrix.
C             The array F is not referenced if FBTYPE = 'I'  or
C             ALPHA = 0.
C
C     LDF     INTEGER
C             The leading dimension of array F.
C             LDF >= MAX(1,M) if FBTYPE = 'O' and ALPHA <> 0.
C             LDF >= 1 if FBTYPE = 'I' or ALPHA = 0.
C
C     K       (input) DOUBLE PRECISION array, dimension (LDK,N)
C             The leading M-by-N part of this array must contain the
C             state feedback matrix K.
C             The array K is not referenced if BETA = 0.
C
C     LDK     INTEGER
C             The leading dimension of the array K.
C             LDK >= MAX(1,M) if BETA <> 0.
C             LDK >= 1 if BETA = 0.
C
C     G       (input) DOUBLE PRECISION array, dimension (LDG,MV)
C             The leading M-by-MV part of this array must contain the
C             system input scaling matrix G.
C
C     LDG     INTEGER
C             The leading dimension of the array G.  LDG >= MAX(1,M).
C
C     H       (input) DOUBLE PRECISION array, dimension (LDH,P)
C             The leading PZ-by-P part of this array must contain the
C             system output scaling matrix H.
C
C     LDH     INTEGER
C             The leading dimension of the array H.  LDH >= MAX(1,PZ).
C
C     RCOND   (output) DOUBLE PRECISION
C             The reciprocal condition number of the matrix
C             I - alpha*D*F.
C
C     BC      (output) DOUBLE PRECISION array, dimension (LDBC,MV)
C             The leading N-by-MV part of this array contains the input
C             matrix Bc of the closed-loop system.
C
C     LDBC    INTEGER
C             The leading dimension of array BC.  LDBC >= MAX(1,N).
C
C     CC      (output) DOUBLE PRECISION array, dimension (LDCC,N)
C             The leading PZ-by-N part of this array contains the
C             system output matrix Cc of the closed-loop system.
C
C     LDCC    INTEGER
C             The leading dimension of array CC.
C             LDCC >= MAX(1,PZ) if N > 0.
C             LDCC >= 1 if N = 0.
C
C     DC      (output) DOUBLE PRECISION array, dimension (LDDC,MV)
C             If JOBD = 'D', the leading PZ-by-MV part of this array
C             contains the direct input/output transmission matrix Dc
C             of the closed-loop system.
C             The array DC is not referenced if JOBD = 'Z'.
C
C     LDDC    INTEGER
C             The leading dimension of array DC.
C             LDDC >= MAX(1,PZ) if JOBD = 'D'.
C             LDDC >= 1 if JOBD = 'Z'.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (LIWORK)
C             LIWORK >= MAX(1,2*P) if JOBD = 'D'.
C             LIWORK >= 1 if JOBD = 'Z'.
C             IWORK is not referenced if JOBD = 'Z'.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= wspace, where
C                   wspace = MAX( 1, M, P*MV, P*P + 4*P ) if JOBD = 'D',
C                   wspace = MAX( 1, M ) if JOBD = 'Z'.
C             For best performance, LDWORK >= MAX( wspace, N*M, N*P ).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  if the matrix I - alpha*D*F is numerically singular.
C
C     METHOD
C
C     The matrices of the closed-loop system have the expressions:
C
C     Ac = A1 + beta*B1*K,      Bc = B1*G,
C     Cc = H*(C1 + beta*D1*K),  Dc = H*D1*G,
C
C     where
C
C     A1 = A + alpha*B*F*E*C,   B1 = B + alpha*B*F*E*D,
C     C1 = E*C,                 D1 = E*D,
C
C     with E = (I - alpha*D*F)**-1.
C
C     NUMERICAL ASPECTS
C
C     The accuracy of computations basically depends on the conditioning
C     of the matrix I - alpha*D*F. If RCOND is very small, it is likely
C     that the computed results are inaccurate.
C
C     CONTRIBUTORS
C
C     A. Varga, German Aerospace Research Establishment,
C     Oberpfaffenhofen, Germany, and V. Sima, Katholieke Univ. Leuven,
C     Belgium, Nov. 1996.
C
C     REVISIONS
C
C     January 14, 1997, February 18, 1998.
C     V. Sima, Research Institute for Informatics, Bucharest, July 2003,
C     Jan. 2005.
C
C     KEYWORDS
C
C     Multivariable system, state-space model, state-space
C     representation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         FBTYPE, JOBD
      INTEGER           INFO, LDA, LDB, LDBC, LDC, LDCC, LDD, LDDC,
     $                  LDF, LDG, LDH, LDK, LDWORK, M, MV, N, P, PZ
      DOUBLE PRECISION  ALPHA, BETA, RCOND
C     .. Array Arguments ..
      INTEGER           IWORK(*)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), BC(LDBC,*), C(LDC,*),
     $                  CC(LDCC,*), D(LDD,*), DC(LDDC,*), DWORK(*),
     $                  F(LDF,*), G(LDG,*), H(LDH,*), K(LDK,*)
C     .. Local Scalars ..
      LOGICAL           LJOBD, OUTPF, UNITF
      INTEGER           LDWP
C     .. External functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External subroutines ..
      EXTERNAL          AB05SD, DGEMM, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX, MIN
C
C     .. Executable Statements ..
C
C     Check the input scalar arguments.
C
      UNITF = LSAME( FBTYPE, 'I' )
      OUTPF = LSAME( FBTYPE, 'O' )
      LJOBD = LSAME( JOBD, 'D' )
C
      INFO = 0
C
      IF( .NOT.UNITF .AND. .NOT.OUTPF ) THEN
         INFO = -1
      ELSE IF( .NOT.LJOBD .AND. .NOT.LSAME( JOBD, 'Z' )  ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( P.LT.0 .OR. UNITF.AND.P.NE.M ) THEN
         INFO = -5
      ELSE IF( MV.LT.0 ) THEN
         INFO = -6
      ELSE IF( PZ.LT.0 ) THEN
         INFO = -7
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -11
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -13
      ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, P ) ) .OR.
     $         ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN
         INFO = -15
      ELSE IF( ( LJOBD .AND. LDD.LT.MAX( 1, P ) ) .OR.
     $    ( .NOT.LJOBD .AND. LDD.LT.1 ) ) THEN
         INFO = -17
      ELSE IF( ( OUTPF .AND. ALPHA.NE.ZERO .AND. LDF.LT.MAX( 1, M ) )
     $  .OR. ( ( UNITF .OR.  ALPHA.EQ.ZERO ) .AND. LDF.LT.1 ) ) THEN
         INFO = -19
      ELSE IF( ( BETA.NE.ZERO .AND. LDK.LT.MAX( 1, M ) ) .OR.
     $         ( BETA.EQ.ZERO .AND. LDK.LT.1 ) ) THEN
         INFO = -21
      ELSE IF( LDG.LT.MAX( 1, M ) ) THEN
         INFO = -23
      ELSE IF( LDH.LT.MAX( 1, PZ ) ) THEN
         INFO = -25
      ELSE IF( LDBC.LT.MAX( 1, N ) ) THEN
         INFO = -28
      ELSE IF( ( N.GT.0 .AND. LDCC.LT.MAX( 1, PZ ) ) .OR.
     $         ( N.EQ.0 .AND. LDCC.LT.1 ) ) THEN
         INFO = -30
      ELSE IF( ( ( LJOBD .AND. LDDC.LT.MAX( 1, PZ ) ) .OR.
     $      ( .NOT.LJOBD .AND. LDDC.LT.1 ) ) ) THEN
         INFO = -32
      ELSE IF( ( LJOBD .AND. LDWORK.LT.MAX( 1, M, P*MV, P*P + 4*P ) )
     $   .OR. (  .NOT.LJOBD .AND. LDWORK.LT.MAX( 1, M ) ) ) THEN
         INFO = -35
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'AB05RD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MAX( N, MIN( M, P ), MIN( MV, PZ ) ).EQ.0 ) THEN
         RCOND = ONE
         RETURN
      END IF
C
C     Apply the partial output feedback u = alpha*F*y + v1
C
      CALL AB05SD( FBTYPE, JOBD, N, M, P, ALPHA, A, LDA, B, LDB, C,
     $             LDC, D, LDD, F, LDF, RCOND, IWORK, DWORK, LDWORK,
     $             INFO )
      IF ( INFO.NE.0 ) RETURN
C
C     Apply the partial state feedback v1 = beta*K*x + v2.
C
C     Compute Ac = A1 + beta*B1*K and C1 <- C1 + beta*D1*K.
C
      IF( BETA.NE.ZERO .AND. N.GT.0 ) THEN
         CALL DGEMM( 'N', 'N', N, N, M, BETA, B, LDB, K, LDK, ONE, A,
     $               LDA )
         IF( LJOBD )
     $       CALL DGEMM( 'N', 'N', P, N, M, BETA, D, LDD, K, LDK, ONE,
     $                   C, LDC )
      END IF
C
C     Apply the input and output conversions v2 = G*v, z = H*y.
C
C     Compute Bc = B1*G.
C
      CALL DGEMM( 'N', 'N', N, MV, M, ONE, B, LDB, G, LDG, ZERO, BC,
     $            LDBC )
C
C     Compute Cc = H*C1.
C
      IF( N.GT.0 )
     $   CALL DGEMM( 'N', 'N', PZ, N, P, ONE, H, LDH, C, LDC, ZERO, CC,
     $               LDCC )
C
C     Compute Dc = H*D1*G.
C
      IF( LJOBD ) THEN
         LDWP = MAX( 1, P )
         CALL DGEMM( 'N', 'N', P, MV, M, ONE, D, LDD, G, LDG, ZERO,
     $               DWORK, LDWP )
         CALL DGEMM( 'N', 'N', PZ, MV, P, ONE, H, LDH, DWORK, LDWP,
     $               ZERO, DC, LDDC )
      END IF
C
      RETURN
C *** Last line of AB05RD ***
      END


PROGRAM A5Q1
!--
!Recieves two array inputs representing a set of intervals and returns all merged non-overlapping intervals
!--
IMPLICIT NONE
INTEGER, DIMENSION (:), ALLOCATABLE :: Xn, Yn
INTEGER :: n, check, output

output = 0
PRINT *, "Solves for all intervals that do not overlap. will merge overlapping intervals."
DO
	PRINT *, "Input the size of arrays X and Y (0 to stop)"
    READ *, n
    IF (n .eq. 0) STOP
    ALLOCATE(Xn(n), Yn(n), STAT=check)
    IF (check .ne. 0) THEN
    	PRINT *, "Allocation unsuccessful for X and Y. Please try again"
    ELSE
		PRINT *, "Please enter the values for X"
        READ *, Xn
        PRINT *, "Please enter the values for Y"
        READ *, Yn
        PRINT *, "Input:"
        PRINT *, "X:", Xn
        PRINT *, "Y:", Yn
        IF (n .eq. 1) THEN
          	PRINT *, 1
        ELSE
          	PRINT *, "Output: "
        	output = Merge(Xn, Yn, n)
            PRINT *, "Numbr of intervals:", output
        END IF
        DEALLOCATE(Xn, Yn)
    END IF
END DO

CONTAINS
INTEGER FUNCTION Merge(X, Y, n)
	INTEGER, DIMENSION (:), INTENT(INOUT) :: X, Y
	INTEGER, INTENT(IN) :: n
	INTEGER :: xi, yi, xj, yj, xk, yk, i, j, tmpx, tmpy
    LOGICAL :: merging
    LOGICAL :: merged

	merging = .true.
   	merged = .false.
	Merge = 1
    ! Isolate the different intervals
	DO WHILE (merging)
		DO i = 1,n
        	xi = X(i)
            yi = Y(i)
            xk = X(i)
            yk = Y(i)
			DO j = 1,n
            	IF (j .ne. i)THEN
                xj = X(j)
                yj = Y(j)
                    IF (xi .le. xj .and. xj .le. yi) THEN
						xk = xi
                        yk = yj
                        IF (xi .ne. xj .and. yi .ne. yj) THEN
                        	merged = .true.
                        END IF
                        X(i) = xk
            			Y(i) = yk
                        X(j) = xk
            			Y(j) = yk
                    ELSE IF (xj .lt. xi .and. xi .lt. yj) THEN
						xk = xj
                        yk = yi
                        IF (xi .ne. xj .and. yi .ne. yj) THEN
                        	merged = .true.
                        END IF
                        X(i) = xk
           				Y(i) = yk
                        X(j) = xk
           				Y(j) = yk
                    END IF
                END IF
			END DO
        END DO
		IF (.not. merged) THEN
        	merging = .false.
        ELSE
          	merged = .false.
        END IF

    END DO
    ! Order the arrays X and Y
    DO i = 1, (n - 1)
      	xi = X(i)
      	yi = Y(i)
       	IF (xi .ne. X(i +1) .and. yi .ne. Y(i + 1)) THEN
			DO j = i + 1, n
            	xj = X(j)
                yj = Y(j)
              	IF (xi .eq. X(j) .and. yi .eq. Y(j)) THEN
           			tmpx = X(i + 1)
                    tmpy = Y(i + 1)
                  	X(i + 1) = X(j)
               		Y(i + 1) = Y(j)
                    X(j) = tmpx
                    Y(j) = tmpy
                END IF
        	END DO
        END IF
    END DO
    ! Now count the number of different intervals in X0 and Y0
    ! Also print all unique pairs
    xi = X(1)
    yi = Y(1)
    PRINT "('(', I3, ' ,', I3, ' )')", xi, yi
    DO j = 2, n
        xj = X(j)
        yj = Y(j)
        IF (xi .ne. xj .and. yi .ne. yj) THEN
			Merge = Merge + 1
            PRINT "('(', I3, ' ,', I3, ' )')", xj, yj
        END IF
		xi = xj
        yi = yj
    END DO

END FUNCTION Merge
END PROGRAM A5Q1


submodule (m_KdTree) sm_KdTree_class
  !! Contains the implementations of overloaded KdTree class type bound procedures
  use m_sort, only: argSort
implicit none

contains

  !====================================================================!
  module procedure init2D_KdTree!(this, x, y)
  !====================================================================!
  !  class(kdTree) :: this
  !    !! KdTree Class
  !  real(r64),intent(in) :: x(:)
  !    !! x-coordinates of the points
  !  real(r64),intent(in) :: y(:)
  !    !! y-coordinates of the points

  integer(i32) :: i, istat
  real(r64), allocatable :: aux(:)

  call this%deallocate()

  ! Initialize the number of entries and dimensions of the tree
  this%N = size(x)
  this%nDims = 2

  ! Set the root node
  call this%trunk%init(1, this%N)

  ! Allocated and initialize the indexer
  call allocate(this%indx, this%N)
  call arange(this%indx, 1, this%N)

  ! Allocate the auxiliary space
  call allocate(aux, this%N)
  aux = 0.d0

  ! Grow the KD tree
  call growKdTree_2D(this%trunk, x, y, this%indx, aux)

  call deallocate(aux)
  this%set=.true.
  end procedure
  !====================================================================!
  !====================================================================!
  recursive subroutine growKdTree_2D(trunk, x, y, indx, aux)
  !====================================================================!
  class(KdTreebranch) :: trunk
  real(r64), intent(in) :: x(:), y(:)
  integer(i32), intent(inout) :: indx(:)
  real(r64), intent(inout) :: aux(:)

  integer(i32) :: i,i1,splitAlong, iMedian, iMid, istat, N
  real(r64) :: maxVariance

  N = trunk%right - trunk%left + 1

  iMid = (trunk%right+trunk%left) / 2

  ! Only recurse through the tree for array sections bigger than a fixed size to prevent tail recursion.
  ! Arrays of size 5 or less are the leaves at the end of the branch
  if (N > 5) then
    ! Assign first dimension as split along to begin with
    do i = 0, N-1
        i1 = indx(trunk%left+i)
        aux(i+1) = x(i1)
    enddo
    maxVariance = variance(aux(1:N))
    splitAlong = 1
    ! Test the second dimension
    do i = 0, N-1
        i1 = indx(trunk%left+i)
        aux(i+1) = y(i1)
    enddo
    if (variance(aux(1:N)) > maxVariance) then
      splitAlong = 2
    end if
    trunk%splitAlong = splitAlong

    iMedian = 0
    select case(splitAlong)
    case(1)
      ! arg select the median value
      call argSelect(x, indx, iMid, iMedian, trunk%left, trunk%right)
      trunk%median = x(iMedian)
    case(2)
      ! arg select the median value
      call argSelect(y, indx, iMid, iMedian, trunk%left, trunk%right)
      trunk%median = y(iMedian)
    end select

    ! Allocate the children nodes
    allocate(trunk%buds(2))
    ! Initialize the children nodes
    call trunk%buds(1)%init(trunk%left, iMid)
    call trunk%buds(2)%init(iMid+1, trunk%right)
    ! Grow the tree through the new branches
    call growKdTree_2D(trunk%buds(1), x, y, indx, aux)
    call growKdTree_2D(trunk%buds(2), x, y, indx, aux)
  end if
  end subroutine
  !====================================================================!

  !====================================================================!
  module procedure init3D_KdTree!(this, x, y, z)
  !====================================================================!
  !  class(kdTree) :: this
  !    !! KdTree Class
  !  real(r64),intent(in) :: x(:)
  !    !! x-coordinates of the points
  !  real(r64),intent(in) :: y(:)
  !    !! y-coordinates of the points
  !  real(r64),intent(in) :: z(:)
  !    !! z-coordinates of the points

  integer(i32) :: i, istat
  real(r64), allocatable :: aux(:)

  call this%deallocate()

  ! Initialize the number of entries and dimensions of the tree
  this%N = size(x)
  this%nDims = 3

  ! Set the root node
  call this%trunk%init(1, this%N)

  ! Allocated and initialize the indexer
  call allocate(this%indx, this%N)
  call arange(this%indx, 1, this%N)

  ! Allocate the auxiliary space
  call allocate(aux, this%N)

  ! Grow the KD tree
  call growKdTree_3D(this%trunk, x, y, z, this%indx, aux)

  call deallocate(aux)
  this%set=.true.
  end procedure
  !====================================================================!
  !====================================================================!
  recursive subroutine growKdTree_3D(trunk, x, y, z, indx, aux)
  !====================================================================!
  class(KdTreebranch) :: trunk
  real(r64), intent(in) :: x(:), y(:), z(:)
  integer(i32), intent(inout) :: indx(:)
  real(r64), intent(inout) :: aux(:)

  integer(i32) :: splitAlong, iMedian, iMid, istat, N
  real(r64) :: maxVariance

  N = trunk%right - trunk%left + 1

  iMid = (trunk%right+trunk%left) / 2

  ! Only recurse through the tree for array sections bigger than a fixed size to prevent tail recursion.
  ! Arrays of size 5 or less are the leaves at the end of the branch
  if (N > 5) then
    ! Assign first dimension as split along to begin with
    aux(1:N) = x(indx(trunk%left:trunk%right))
    maxVariance = variance(aux(1:N))
    splitAlong = 1
    ! Test the second dimension
    aux(1:N) = y(indx(trunk%left:trunk%right))
    if (variance(aux(1:N)) > maxVariance) then
      splitAlong = 2
    end if
    ! Test the thrid dimension
    aux(1:N) = z(indx(trunk%left:trunk%right))
    if (variance(aux(1:N)) > maxVariance) then
      splitAlong = 3
    end if
    trunk%splitAlong = splitAlong

    iMedian = 0
    select case(splitAlong)
    case(1)
      ! arg select the median value
      call argSelect(x, indx, iMid, iMedian, trunk%left, trunk%right)
      trunk%median = x(iMedian)
    case(2)
      ! arg select the median value
      call argSelect(y, indx, iMid, iMedian, trunk%left, trunk%right)
      trunk%median = y(iMedian)
    case(3)
      ! arg select the median value
      call argSelect(z, indx, iMid, iMedian, trunk%left, trunk%right)
      trunk%median = z(iMedian)
    end select

    ! Allocate the children nodes
    allocate(trunk%buds(2))
    ! Initialize the children nodes
    call trunk%buds(1)%init(trunk%left, iMid)
    call trunk%buds(2)%init(iMid+1, trunk%right)
    ! Grow the tree through the new branches
    call growKdTree_3D(trunk%buds(1),x,y,z,indx, aux)
    call growKdTree_3D(trunk%buds(2),x,y,z,indx, aux)
  end if
  end subroutine
  !====================================================================!

  !====================================================================!
  module procedure initKD_KdTree!(this, D)
  !====================================================================!
  !  class(kdTree) :: this
  !    !! KdTree Class
  !  real(r64),intent(in) :: D(:,:)
  !    !! Co-ordinates of the points, the k columns contain the k dimensional values.

  integer(i32) :: i, istat
  real(r64), allocatable :: aux(:)

  call this%deallocate()

  ! Initialize the number of entries and dimensions of the tree
  this%N = size(D, 1)
  this%nDims = size(D, 2)

  ! Set the root node
  call this%trunk%init(1, this%N)

  ! Allocated and initialize the indexer
  call allocate(this%indx, this%N)
  call arange(this%indx, 1, this%N)

  ! Allocate the auxiliary space
  call allocate(aux, this%N)

  ! Grow the KD tree
  call growKdTree_KD(this%trunk, D, this%indx, aux)

  call deallocate(aux)
  this%set=.true.
  end procedure
  !====================================================================!
  !====================================================================!
  recursive subroutine growKdTree_KD(trunk, D, indx, aux)
  !====================================================================!
  class(KdTreebranch) :: trunk
  real(r64), intent(in) :: D(:,:)
  integer(i32), intent(inout) :: indx(:)
  real(r64), intent(inout) :: aux(:)

  integer(i32) :: splitAlong, iMedian, iMid, istat, k, N, nDims
  real(r64) :: maxVariance,varianceTmp

  nDims = size(D, 2)

  N = trunk%right - trunk%left + 1

  iMid = (trunk%right+trunk%left) / 2

  ! Only recurse through the tree for array sections bigger than a fixed size to prevent tail recursion.
  ! Arrays of size 5 or less are the leaves at the end of the branch
  if (N > 5) then
    ! Assign first dimension as split along to begin with
    aux(1:N) = D(indx(trunk%left:trunk%right),1)
    maxVariance = variance(aux(1:N))
    splitAlong = 1
    ! Test the other dimensions
    do k = 2,nDims
      aux(1:N) = D(indx(trunk%left:trunk%right), k)
      varianceTmp = variance(aux(1:N))
      if (varianceTmp > maxVariance) then
        maxVariance = varianceTmp
        splitAlong = k
      end if
    enddo

    iMedian = 0
    ! arg select the median value
    call argSelect(D(:, splitAlong), indx, iMid, iMedian, trunk%left, trunk%right)
    trunk%median = D(iMedian, splitAlong)

    ! Allocate the children nodes
    allocate(trunk%buds(2))
    ! Initialize the children nodes
    call trunk%buds(1)%init(trunk%left, iMid)
    call trunk%buds(2)%init(iMid+1, trunk%right)
    ! Grow the tree through the new branches
    call growKdTree_KD(trunk%buds(1), D, indx, aux)
    call growKdTree_KD(trunk%buds(2), D, indx, aux)
  end if
  end subroutine
  !====================================================================!

  !====================================================================!
  module procedure deallocate_KdTree
    !! Overloaded type bound procedure KdTree%deallocate()
  !====================================================================!
  call deallocate(this%indx)
  call this%trunk%deallocate()
  end procedure
  !====================================================================!
end submodule


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   Example 1: The AP BP normal form
!----------------------------------------------------------------------
!----------------------------------------------------------------------

SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)

  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM, IJAC, ICP(*)
  DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
  DOUBLE PRECISION, INTENT(OUT) :: F(NDIM), DFDU(NDIM,*), DFDP(NDIM,*)

  F(1) = (U(1)-PAR(1))*(U(1)-PAR(2))+PAR(3)

  IF(IJAC==0)RETURN

  DFDU(1,1) = U(1)-PAR(1)+U(1)-PAR(2)

  IF(IJAC==1)RETURN

  DFDP(1,1) = -(U(1)-PAR(2))
  DFDP(1,2) = -(U(1)-PAR(1))
  DFDP(1,3) = 1.0d0

END SUBROUTINE FUNC

!-----------------------------------------------------------------------
!-----------------------------------------------------------------------

SUBROUTINE STPNT(NDIM,U,PAR)
!--------- -----

  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM
  DOUBLE PRECISION, INTENT(OUT) :: U(NDIM), PAR(*)

  PAR(1:3) = (/ 1.0d0, 2.0d0, 0.0d0 /)

  U(1) = 1.0

END SUBROUTINE STPNT

!----------------------------------------------------------------------
!----------------------------------------------------------------------

SUBROUTINE BCND
END SUBROUTINE BCND

SUBROUTINE ICND
END SUBROUTINE ICND

SUBROUTINE FOPT
END SUBROUTINE FOPT

SUBROUTINE PVLS
END SUBROUTINE PVLS

!----------------------------------------------------------------------
!----------------------------------------------------------------------


subroutine formkb(kb,km,g)
! lower triangular global stiffness kb stored as kb(n,iw+1)
 implicit none
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),intent(in)::km(:,:)
 REAL(iwp),intent(out)::kb(:,:)
 integer,intent(in)::g(:)
 integer::iw,idof,i,j,icd
 idof=size(km,1)
 iw=size(kb,2)-1
 do i=1,idof
   if(g(i)>0)then
     do j=1,idof
       if(g(j)>0)then
         icd=g(j)-g(i)+iw+1
         if(icd-iw-1<=0)kb(g(i),icd)=kb(g(i),icd)+km(i,j)
       end if
     end do
   end if
 end do
return
end subroutine formkb


program lorenz

real(8), parameter :: dt = 1e-4, d0 = 1e-8
integer, parameter :: N_spin = 1000000, N_run = 1000000
real(8) :: beta, sigma, rho, x_a, y_a, z_a, x_b, y_b, z_b, d1, lyap = 0
integer :: i
namelist /params/ beta, sigma, rho
character(30) :: sim_id

call get_command_argument(1, sim_id)
open(1, file="params_" // trim(sim_id) // ".nml")
read(1, nml=params)

! Spin-up
x_a = 1; y_a = 1; z_a = 1
do i = 1, N_spin
  call integrate(x_a, y_a, z_a)
end do

! Choose point a distance of d0 away
x_b = x_a + d0/sqrt(3.)
y_b = y_a + d0/sqrt(3.)
z_b = z_a + d0/sqrt(3.)

! Calculate largest Lyapunov exponent
do i = 1, N_run
  call integrate(x_a, y_a, z_a)
  call integrate(x_b, y_b, z_b)

  d1 = norm2((/ x_a, y_a, z_a /) - (/ x_b, y_b, z_b /))
  lyap = lyap + log(abs(d1/d0))

  ! Rescale
  x_b = x_a + d0*(x_b - x_a)/d1
  y_b = y_a + d0*(y_b - y_a)/d1
  z_b = z_a + d0*(z_b - z_a)/d1
end do

lyap = lyap/(N_run*dt)

open(2, file="results_" // trim(sim_id) // ".txt", action="write")
write(2, *) lyap

contains
  subroutine integrate(x, y, z)
    ! Integrate using midpoint method
    real(8), intent(inout) :: x, y, z
    real(8) :: x_temp, y_temp, z_temp
    x_temp = x + dt*sigma*(y - x)/2
    y_temp = y + dt*(x*(rho - z) - y)/2
    z_temp = z + dt*(x*y - beta*z)/2
    x = x + dt*sigma*(y_temp - x_temp)
    y = y + dt*(x_temp*(rho - z_temp) - y_temp)
    z = z + dt*(x_temp*y_temp - beta*z_temp)
  end subroutine
end program


      subroutine runCP_0000i(i1,Gr,S0000i,N0)
      implicit none
      include 'TRconstants.f'
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,i1,m,n,np
      parameter(np=2)
      double precision Gr(np,np)
      double complex S0000i(np,-2:0),bit,pole

      do ep=-2,0
      bit=czip
      do n=1,np
      do m=1,np
      bit=bit+Gr(n,m)*Cv(czziii(z3(n,m,i1))+N0,ep)
      enddo
      enddo

      pole=czip
      if (ep .gt. -2) pole=4d0*Cv(czzzzi(i1)+N0,ep-1)

c--- note: we have simplified the recursion relation by using DD (5.9)
c--- so that S0000i = 2B00i(0)+2*m0sq*C00i
      Cv(czzzzi(i1)+N0,ep)=
     . (pole
     . +S0000i(i1,ep)
     . -bit)/16d0
      enddo

      return
      end


      subroutine albedo
!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine calculates albedo in the HRU for the day
!!

      use hru_module, only : hru, ihru, albday
      use soil_module
      use plant_module
      use organic_mineral_mass_module

      implicit none

      real :: cej       !none           |constant
      real :: eaj       !none           |soil cover index
      integer :: j      ! none          |HRU number
      real :: cover     !kg/ha          |soil cover

      j = ihru

!! calculate albedo
      cej = -5.e-5
      cover = pl_mass(j)%ab_gr_com%m + rsd1(j)%tot_com%m
      eaj = Exp(cej * (cover + .1))   !! equation 2.2.16 in SWAT manual

      if (hru(j)%sno_mm <= .5) then
        !! equation 2.2.14 in SWAT manual
        albday = soil(j)%ly(1)%alb

        !! equation 2.2.15 in SWAT manual
        if (pcom(j)%lai_sum > 0.) albday = .23 * (1. - eaj) + soil(j)%ly(1)%alb * eaj
      else
        !! equation 2.2.13 in SWAT manual
        albday = 0.8
      end if

      return
      end subroutine albedo


c
c-----------------------------------------------------------------------
c subroutine: iftaoh
c compute idft for real, antisymmetric, odd harmonic, n-point sequence
c using n/4-point fft
c antisymmetric sequence means x(m)=-x(n-m), m=1,...,n/2-1
c odd harmonic means x(2*k)=0, all k, where x(k) is the dft of x(m)
c x(m)has the property x(m)=x(n/2-m), m=0,1,...,n/4-1,  x(0)=0
c note: index m is sequence index--not fortran index
c-----------------------------------------------------------------------
c
      subroutine iftaoh(x, n, y)
      dimension x(1), y(1)
c
c  x = real array which on input contains the n/4 imaginary points
c      of the odd harmonics of the transform of the original time
c      sequence--i.e. the zero valued real parts are not input nor
c      are the zero-valued even harmonics
c      on output x contains the first (n/4+1) points of the original
c      time sequence (antisymmetrical)
c  n = true size of input
c  y = scratch array of size n/4+2
c
c
c handle n = 2 and n = 4 cases separately
c
      if (n.gt.4) go to 20
      if (n.eq.4) go to 10
c
c for n=2  assume x(1)=0, x(2)=0, compute idft directly
c
      x(1) = 0.
      return
c
c for n=4, assume x(1)=x(3)=0, x(2)=-x(4)=x0, compute idft directly
c
  10  x(2) = -x(1)/2.
      x(1) = 0.
      return
c
c code for values of n which are multiples of 8
c
  20  twopi = 8.*atan(1.0)
      no2 = n/2
      no4 = n/4
      no8 = n/8
      tpn = twopi/float(n)
c
c scramble original dft (x(k)) to give y(k)
c use recursion to give sin multipliers
c
      cosi = cos(tpn)
      sini = sin(tpn)
      cosd = cos(tpn*2.)
      sind = sin(tpn*2.)
      do 30 i=1,no8
        ind = 2*i
        ind1 = no4 + 1 - i
        ak = (x(i)-x(ind1))/2.
        bk = -(x(i)+x(ind1))
        y(ind) = ak
        y(ind-1) = bk*sini
        temp = cosi*cosd - sini*sind
        sini = cosi*sind + sini*cosd
        cosi = temp
  30  continue
c
c the sequence y(k) is an odd harmonic sequence
c use subroutine iftohm to give y(m)
c
      call iftohm(y, no2)
c
c form x sequence from y sequence
c
      x(2) = y(1)/2.
      x(1) = 0.
      if (n.eq.8) return
      do 40 i=2,no8
        ind = 2*i
        ind1 = no4 + 2 - i
        x(ind-1) = (y(i)+y(ind1))/2.
        t1 = (y(i)-y(ind1))/2.
        x(ind) = t1 + x(ind-2)
  40  continue
      x(no4+1) = y(no8+1)
      return
      end


!==========================================================================
elemental subroutine gsw_t_freezing_first_derivatives_poly (sa, p, &
                            saturation_fraction, tfreezing_sa, tfreezing_p)
!==========================================================================
!
!  Calculates the frist derivatives of the in-situ temperature at which
!  seawater freezes with respect to Absolute Salinity SA and pressure P (in
!  Pa).  These expressions come from differentiating the expression that
!  defines the freezing temperature, namely the equality between the
!  chemical potentials of water in seawater and in ice.
!
!  SA  =  Absolute Salinity                                        [ g/kg ]
!  p   =  sea pressure                                             [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar )
!  saturation_fraction = the saturation fraction of dissolved air in
!                        seawater
!
!  tfreezing_SA = the derivative of the in-situ freezing temperature
!                 (ITS-90) with respect to Absolute Salinity at fixed
!                 pressure                     [ K/(g/kg) ] i.e. [ K kg/g ]
!
!  tfreezing_P  = the derivative of the in-situ freezing temperature
!                 (ITS-90) with respect to pressure (in Pa) at fixed
!                 Absolute Salinity                                [ K/Pa ]
!--------------------------------------------------------------------------

use gsw_mod_teos10_constants, only : gsw_sso

use gsw_mod_freezing_poly_coefficients

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, p, saturation_fraction
real (r8), intent(out), optional :: tfreezing_sa, tfreezing_p

real (r8) :: p_r, sa_r, x

real (r8), parameter :: c = 1e-3_r8/(2.0_r8*gsw_sso)

sa_r = sa*1e-2_r8
x = sqrt(sa_r)
p_r = p*1e-4_r8

if (present(tfreezing_sa)) tfreezing_sa = &
    (t1 + x*(1.5_r8*t2 + x*(2.0_r8*t3 + x*(2.5_r8*t4 + x*(3.0_r8*t5 &
        + 3.5_r8*t6*x)))) + p_r*(t10 + x*(1.5_r8*t11 + x*(2.0_r8*t13 &
	+ x*(2.5_r8*t16 + x*(3.0_r8*t19 + 3.5_r8*t22*x)))) &
        + p_r*(t12 + x*(1.5_r8*t14 + x*(2.0_r8*t17 + 2.5_r8*t20*x)) &
        + p_r*(t15 + x*(1.5_r8*t18 + 2.0_r8*t21*x)))))*1e-2_r8 &
        + saturation_fraction*c

if (present(tfreezing_p)) tfreezing_p = &
    (t7 + sa_r*(t10 + x*(t11 + x*(t13 + x*(t16 + x*(t19 + t22*x))))) &
        + p_r*(2.0_r8*t8 + sa_r*(2.0_r8*t12 + x*(2.0_r8*t14 + x*(2.0_r8*t17 &
	+ 2.0_r8*t20*x))) + p_r*(3.0_r8*t9 + sa_r*(3.0_r8*t15 + x*(3.0_r8*t18 &
	+ 3.0_r8*t21*x)))))*1e-8_r8

return
end subroutine

!--------------------------------------------------------------------------


      subroutine qlbox2(Y,musq,Ires)
C $I_4^{D=4-2 \epsilon}(0,0,0,\pq^2;s_{12},s_{23};0,0,0,0)$}
C     One mass integral as given in egz2, Eq.(A22).
c                          [                  s12    p4sq ]
c                          [   0       0    - ---  - ---- ]
c                          [                   2      2   ]
c                          [                              ]
c                          [                         s23  ]
c                          [   0       0      0    - ---  ]
c                          [                          2   ]
c                     Y2 = [                              ]
c                          [   s12                        ]
c                          [ - ---     0      0      0    ]
c                          [    2                         ]
c                          [                              ]
c                          [   p4sq    s23                ]
c                          [ - ----  - ---    0      0    ]
c                          [    2       2                 ]
      implicit none
      double precision musq,si,ta,mp4sq,Y(4,4)
      double complex Ires(-2:0),qlLsm1,qllnrat,ctwo,fac
      parameter(ctwo=(2d0,0d0))

      si=2d0*Y(1,3)
      ta=2d0*Y(2,4)
      mp4sq=2d0*Y(1,4)
      fac=dcmplx(1d0/(si*ta))
      Ires(-2)=fac*ctwo
      Ires(-1)=fac*ctwo
     . *(qllnrat(mp4sq,musq)
     .  -qllnrat(ta,musq)
     .  -qllnrat(si,musq))
      Ires( 0)=fac*(-qllnrat(mp4sq,musq)**2
     . +qllnrat(ta,musq)**2
     . +qllnrat(si,musq)**2
     . +ctwo*(qlLsm1(ta,mp4sq,si,mp4sq)
     . -qllnrat(ta,mp4sq)*qllnrat(si,mp4sq))
     . +qllnrat(mp4sq,ta)**2+qllnrat(mp4sq,si)**2
     . -qllnrat(ta,si)**2)

      return
      end


!==========================================================================
elemental function gsw_pt_from_ct (sa, ct)
!==========================================================================
!
! potential temperature of seawater from conservative temperature
!
! sa     : Absolute Salinity                               [g/kg]
! ct     : Conservative Temperature                        [deg C]
! p      : sea pressure                                    [dbar]
!
! gsw_pt_from_ct : potential temperature with              [deg C]
!                  reference pressure of  0 dbar
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_ct_from_pt, gsw_gibbs_pt0_pt0

use gsw_mod_teos10_constants, only : gsw_cp0, gsw_ups, gsw_t0

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, ct

real (r8) :: gsw_pt_from_ct

real (r8) :: a5ct, b3ct, ct_factor, pt_num, pt_recden, ct_diff
real (r8) :: ct0, pt, pt_old, ptm, dct, dpt_dct, s1

real (r8), parameter :: a0 = -1.446013646344788e-2_r8
real (r8), parameter :: a1 = -3.305308995852924e-3_r8
real (r8), parameter :: a2 =  1.062415929128982e-4_r8
real (r8), parameter :: a3 =  9.477566673794488e-1_r8
real (r8), parameter :: a4 =  2.166591947736613e-3_r8
real (r8), parameter :: a5 =  3.828842955039902e-3_r8

real (r8), parameter :: b0 =  1.0_r8
real (r8), parameter :: b1 =  6.506097115635800e-4_r8
real (r8), parameter :: b2 =  3.830289486850898e-3_r8
real (r8), parameter :: b3 =  1.247811760368034e-6_r8

s1 = sa/gsw_ups

a5ct = a5*ct
b3ct = b3*ct

ct_factor = (a3 + a4*s1 + a5ct)
pt_num = a0 + s1*(a1 + a2*s1) + ct*ct_factor
pt_recden = 1.0_r8/(b0 + b1*s1 + ct*(b2 + b3ct))
pt = pt_num*pt_recden

dpt_dct = (ct_factor + a5ct - (b2 + b3ct + b3ct)*pt)*pt_recden

! Start the 1.5 iterations through the modified Newton-Rapshon iterative,
! method, which is also known as the Newton-McDougall method.

ct_diff = gsw_ct_from_pt(sa,pt) - ct
pt_old = pt
pt = pt_old - ct_diff*dpt_dct
ptm = 0.5_r8*(pt + pt_old)

dpt_dct = -gsw_cp0/((ptm + gsw_t0)*gsw_gibbs_pt0_pt0(sa,ptm))

pt = pt_old - ct_diff*dpt_dct
ct_diff = gsw_ct_from_pt(sa,pt) - ct
pt_old = pt
gsw_pt_from_ct = pt_old - ct_diff*dpt_dct

return
end function

!--------------------------------------------------------------------------


module fdr

  use types, only: dp

  implicit none

contains

  subroutine coordsFromLinear(n, k, i, j)
    integer, intent(in) :: n, k
    integer, intent(out) :: i, j

    i = int(n - (sqrt(real(-8 * k + (2 * n - 1)**2 + 8, dp)) - 1) / 2)
    j = i * (i + 1) / 2 - i * n + k + n
  end subroutine coordsFromLinear

  function poisbinomTest(data, bg, lowerTail) result(p)
    use poisbinom, only: cdf

    integer, dimension(:, :), intent(in) :: data
    real(dp), dimension(size(data, 1), size(data, 2)), intent(in) :: bg
    logical, intent(in) :: lowerTail

    real(dp), dimension(size(data, 1) * (size(data, 1) - 1) / 2) :: p

    integer :: i, j, k, n

    n = size(data, 1)

    !$omp parallel do private(i, j)
    do k = 1, n * (n - 1) / 2
       call coordsFromLinear(n, k, i, j)    ! k = j + n * (i - 1) - i * (i + 1) / 2
       if (lowerTail) then
          p(k) = cdf(bg(i, :) * bg(j, :), dot_product(data(i, :), data(j, :)))
       else
          p(k) = 1 - cdf(bg(i, :) * bg(j, :), dot_product(data(i, :), data(j, :)) - 1)
       end if
    end do
    !$omp end parallel do
  end function poisbinomTest

  function expectedP(cdf)
    real(dp), dimension(0:), intent(in) :: cdf
    real(dp) :: expectedP

    integer :: i

    expectedP = cdf(0)**2
    do i = 1, ubound(cdf, 1)
       expectedP = expectedP + cdf(i) * (cdf(i) - cdf(i - 1))
    end do
  end function expectedP

  function mutex(data, bg, lowerTail, estimate_fdr, q, pi0) result (p)
    use util, only: bincount, cummin, cumsum, unique

    integer, dimension(:, :), intent(in) :: data
    real(dp), dimension(size(data, 1), size(data, 2)), intent(in) :: bg
    logical, intent(in) :: lowerTail
    logical, intent(in) :: estimate_fdr
    real(dp), intent(out) :: pi0

    real(dp), dimension(size(data, 1) * (size(data, 1) - 1) / 2) :: p

    real(dp), dimension(size(p)), intent(out) :: q

    real(dp), dimension(:), allocatable :: sortedLevels
    integer, dimension(size(p)) :: inv
    integer, dimension(:), allocatable :: counts
    real(dp), dimension(:), allocatable :: qUnique

    real(dp) :: expectedP0

    integer :: i, j, n, t

    p = poisbinomTest(data, bg, lowerTail)

    if (estimate_fdr) then
       call unique(p, sortedLevels, inv)
       allocate(qUnique(size(sortedLevels)))

       qUnique = 0
       expectedP0 = 0

       n = size(data, 1)

       !$omp parallel do private(i, j) reduction(+:qUnique,expectedP0)
       do t = 1, n * (n - 1) / 2
          call coordsFromLinear(n, t, i, j)
          call updateQ(bg(i, :) * bg(j, :), lowerTail, sortedLevels, qUnique, expectedP0)
       end do
       !$omp end parallel do

       counts = cumsum(bincount(inv))
       qUnique = cumsum(qUnique) / counts
       where (qUnique > 1) qUnique = 1
       call cummin(qUnique)

       do i = 1, size(inv)
          q(i) = qUnique(inv(i))
       end do

       print *, "expected P:", expectedP0 / size(p)
       print *, "mean P:", sum(p) / size(p)
       pi0 = min(1.0_dp, sum(p) / expectedP0)
       print *, "pi0:", pi0
    end if
  end function mutex

  function computeP(chrom1, p1, chrom2, p2, lowerTail) result(p)
    use poisbinom

    integer, dimension(:, :), intent(in) :: chrom1
    real(dp), dimension(size(chrom1, 1), size(chrom1, 2)), intent(in) :: p1
    integer, dimension(:, :), intent(in) :: chrom2
    real(dp), dimension(size(chrom2, 1), size(chrom2, 2)), intent(in) :: p2
    logical, intent(in) :: lowerTail

    real(dp), dimension(size(chrom1, 1), size(chrom2, 1)) :: p

    integer :: i, j

    !$omp parallel do collapse(2)
    do i = 1, size(chrom1, 1)
       do j = 1, size(chrom2, 1)
          if (lowerTail) then
             p(i, j) = cdf(p1(i, :) * p2(j, :), dot_product(chrom1(i, :), chrom2(j, :)))
          else
             p(i, j) = max(1 - cdf(p1(i, :) * p2(j, :), dot_product(chrom1(i, :), chrom2(j, :)) - 1), 0.0_dp)
          end if
       end do
    end do
    !$omp end parallel do
  end function computeP

  subroutine updateQ(p, lowerTail, sortedLevels, qUnique, expectedP0)
    use poisbinom, only: fullCdf
    use util, only: insertionPoints

    real(dp), dimension(:), intent(in) :: p
    logical, intent(in) :: lowerTail
    real(dp), dimension(:), intent(in) :: sortedLevels
    real(dp), dimension(size(sortedLevels)), intent(inout) :: qUnique
    real(dp), intent(inout) :: expectedP0

    real(dp), dimension(0:size(p)) :: cdf
    integer, dimension(0:size(p)) :: k
    integer :: l

    if (lowerTail) then
       cdf = fullCdf(p, size(p))
    else
       cdf = fullCdf(1 - p, size(p))
    end if

    expectedP0 = expectedP0 + expectedP(cdf)

    k = insertionPoints(cdf, sortedLevels)
    qUnique(k(0)) = qUnique(k(0)) + cdf(0)

    do l = 1, ubound(k, 1)
       if (k(l) == -1) then
          exit
       else
          qUnique(k(l)) = qUnique(k(l)) + cdf(l) - cdf(l - 1)
       end if
    end do
  end subroutine updateQ

  subroutine updateMultiQ(bg1, bg2, lowerTail, sortedLevels, qUnique, expectedP0)
    real(dp), dimension(:, :), intent(in) :: bg1
    real(dp), dimension(:, :), intent(in) :: bg2
    logical, intent(in) :: lowerTail
    real(dp), dimension(:), intent(in) :: sortedLevels
    real(dp), dimension(size(sortedLevels)), intent(inout) :: qUnique
    real(dp), intent(inout) :: expectedP0

    integer :: i, j

    !$omp parallel do collapse(2) reduction(+:qUnique,expectedP0)
    do i = 1, size(bg1, 1)
       do j = 1, size(bg2, 1)
          call updateQ(bg1(i, :) * bg2(j, :), lowerTail, sortedLevels, qUnique, expectedP0)
       end do
    end do
    !$omp end parallel do
  end subroutine updateMultiQ

  function analyseBlockStructure(data, bg, lowerTail, blockLengths, estimate_fdr, qMatrix, pi0) result (pMatrix)
    use, intrinsic :: ieee_arithmetic, only: ieee_value, ieee_quiet_nan
    use util, only: bincount, cummin, cumsum, unique

    integer, dimension(:, :), intent(in) :: data
    real(dp), dimension(size(data, 1), size(data, 2)), intent(in) :: bg
    logical, intent(in) :: lowerTail
    integer, dimension(:), intent(in) :: blockLengths
    logical, intent(in) :: estimate_fdr
    real(dp), dimension(size(data, 1), size(data, 1)), intent(out) :: qMatrix
    real(dp), intent(out) :: pi0
    real(dp), dimension(size(data, 1), size(data, 1)) :: pMatrix

    real(dp), dimension(:), allocatable :: p
    integer, dimension(size(blockLengths)) :: offsets, flatOffsets
    integer :: i, start1, end1, start2, k1, k2

    real(dp), dimension(:), allocatable :: sortedLevels
    integer, dimension(:), allocatable :: inv
    integer, dimension(:), allocatable :: counts
    real(dp), dimension(:), allocatable :: qUnique
    real(dp), dimension(:), allocatable :: q
    real(dp) :: expectedP0

    ! size(blockLengths) should be > 1

    !offsets(1) = 0
    !offsets(2:) = cumsum(blockLengths)(2:)
    offsets = cumsum(blockLengths)
    offsets(2:) = offsets(:size(offsets - 1)) + 1
    offsets(1) = 1

    flatOffsets(1) = 1
    flatOffsets(2:) = cumsum([ (blockLengths(i) * sum(blockLengths(i + 1:)), i = 1, size(blockLengths) - 1) ]) + 1

    allocate(p(sum([ (blockLengths(i) * sum(blockLengths(i+1:)), i = 1, size(blockLengths) - 1) ])))

    do i = 1, size(blockLengths) - 1
       start1 = offsets(i)
       end1 = offsets(i + 1) - 1
       start2 = offsets(i + 1)
       k1 = flatOffsets(i)
       k2 = flatOffsets(i + 1) - 1
       p(k1:k2) = reshape(computeP(data(start1:end1, :), bg(start1:end1, :), data(start2:, :), bg(start2:, :), lowerTail), [k2 - k1 + 1])
    end do

    if (estimate_fdr) then
       allocate(inv(size(p)))
       call unique(p, sortedLevels, inv)
       allocate(qUnique(size(sortedLevels)))

       qUnique = 0
       expectedP0 = 0
       do i = 1, size(blockLengths) - 1
          start1 = offsets(i)
          end1 = offsets(i + 1) - 1
          start2 = offsets(i + 1)
          call updateMultiQ(bg(start1:end1, :), bg(start2:, :), lowerTail, sortedLevels, qUnique, expectedP0)
       end do

       counts = cumsum(bincount(inv))
       qUnique = cumsum(qUnique) / counts
       where (qUnique > 1) qUnique = 1
       call cummin(qUnique)
       allocate(q(size(p)))

       do i = 1, size(inv)
          q(i) = qUnique(inv(i))
       end do

       print *, "expected P:", expectedP0 / size(p)
       print *, "mean P:", sum(p) / size(p)
       pi0 = min(1.0_dp, sum(p) / expectedP0)
       print *, "pi0:", pi0
    end if

    pMatrix = ieee_value(1.0_dp, ieee_quiet_nan)
    qMatrix = ieee_value(1.0_dp, ieee_quiet_nan)
    do i = 1, size(blockLengths) - 1
       start1 = offsets(i)
       end1 = offsets(i + 1) - 1
       start2 = offsets(i + 1)
       k1 = flatOffsets(i)
       k2 = flatOffsets(i + 1) - 1
       pMatrix(start1:end1, start2:) = reshape(p(k1:k2), [end1 - start1 + 1, size(data, 1) - start2 + 1])
       if (estimate_fdr) then
          qMatrix(start1:end1, start2:) = reshape(q(k1:k2), [end1 - start1 + 1, size(data, 1) - start2 + 1])
       end if
    end do
  end function analyseBlockStructure

end module fdr


MODULE f1dim_mod
	USE nrtype
	INTEGER(I4B) :: ncom
	REAL(SP), DIMENSION(:), POINTER :: pcom,xicom
CONTAINS
!BL
	FUNCTION f1dim(x)
	IMPLICIT NONE
	REAL(SP), INTENT(IN) :: x
	REAL(SP) :: f1dim
	INTERFACE
		FUNCTION SMM(p)
		USE nrtype;use dimensions
		IMPLICIT NONE
		REAL(SP), DIMENSION(parameters_to_est), INTENT(IN) :: p
		REAL(SP) :: SMM
		END FUNCTION SMM
	END INTERFACE
	REAL(SP), DIMENSION(:), ALLOCATABLE :: xt
	allocate(xt(ncom))
	xt(:)=pcom(:)+x*xicom(:)
	f1dim=SMM(xt)
	deallocate(xt)
	END FUNCTION f1dim
END MODULE f1dim_mod

	SUBROUTINE linmin(p,xi,fret)
	USE nrtype; USE nrutil, ONLY : assert_eq
	USE nr, ONLY : mnbrak,brent
	USE f1dim_mod
	IMPLICIT NONE
	REAL(SP), INTENT(OUT) :: fret
	REAL(SP), DIMENSION(:), TARGET, INTENT(INOUT) :: p,xi
	REAL(SP), PARAMETER :: TOL=1.0e-4_sp
	REAL(SP) :: ax,bx,fa,fb,fx,xmin,xx
	ncom=assert_eq(size(p),size(xi),'linmin')
	pcom=>p
	xicom=>xi
	ax=0.0
	xx=1.0
	call mnbrak(ax,xx,bx,fa,fx,fb,f1dim)
	fret=brent(ax,xx,bx,f1dim,TOL,xmin)
	xi=xmin*xi
	p=p+xi
	END SUBROUTINE linmin


*DECK DBETAI
      DOUBLE PRECISION FUNCTION DBETAI (X, PIN, QIN)
C***BEGIN PROLOGUE  DBETAI
C***PURPOSE  Calculate the incomplete Beta function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7F
C***TYPE      DOUBLE PRECISION (BETAI-S, DBETAI-D)
C***KEYWORDS  FNLIB, INCOMPLETE BETA FUNCTION, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C   DBETAI calculates the DOUBLE PRECISION incomplete beta function.
C
C   The incomplete beta function ratio is the probability that a
C   random variable from a beta distribution having parameters PIN and
C   QIN will be less than or equal to X.
C
C     -- Input Arguments -- All arguments are DOUBLE PRECISION.
C   X      upper limit of integration.  X must be in (0,1) inclusive.
C   PIN    first beta distribution parameter.  PIN must be .GT. 0.0.
C   QIN    second beta distribution parameter.  QIN must be .GT. 0.0.
C
C***REFERENCES  Nancy E. Bosten and E. L. Battiste, Remark on Algorithm
C                 179, Communications of the ACM 17, 3 (March 1974),
C                 pp. 156.
C***ROUTINES CALLED  D1MACH, DLBETA, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890911  Removed unnecessary intrinsics.  (WRB)
C   890911  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920528  DESCRIPTION and REFERENCES sections revised.  (WRB)
C***END PROLOGUE  DBETAI
      DOUBLE PRECISION X, PIN, QIN, ALNEPS, ALNSML, C, EPS, FINSUM, P,
     1  PS, Q, SML, TERM, XB, XI, Y, D1MACH, DLBETA, P1
      LOGICAL FIRST
      SAVE EPS, ALNEPS, SML, ALNSML, FIRST
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  DBETAI
      IF (FIRST) THEN
         EPS = D1MACH(3)
         ALNEPS = LOG (EPS)
         SML = D1MACH(1)
         ALNSML = LOG (SML)
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LT. 0.D0 .OR. X .GT. 1.D0) CALL XERMSG ('SLATEC', 'DBETAI',
     +   'X IS NOT IN THE RANGE (0,1)', 1, 2)
      IF (PIN .LE. 0.D0 .OR. QIN .LE. 0.D0) CALL XERMSG ('SLATEC',
     +   'DBETAI', 'P AND/OR Q IS LE ZERO', 2, 2)
C
      Y = X
      P = PIN
      Q = QIN
      IF (Q.LE.P .AND. X.LT.0.8D0) GO TO 20
      IF (X.LT.0.2D0) GO TO 20
      Y = 1.0D0 - Y
      P = QIN
      Q = PIN
C
 20   IF ((P+Q)*Y/(P+1.D0).LT.EPS) GO TO 80
C
C EVALUATE THE INFINITE SUM FIRST.  TERM WILL EQUAL
C Y**P/BETA(PS,P) * (1.-PS)-SUB-I * Y**I / FAC(I) .
C
      PS = Q - AINT(Q)
      IF (PS.EQ.0.D0) PS = 1.0D0
      XB = P*LOG(Y) - DLBETA(PS,P) - LOG(P)
      DBETAI = 0.0D0
      IF (XB.LT.ALNSML) GO TO 40
C
      DBETAI = EXP (XB)
      TERM = DBETAI*P
      IF (PS.EQ.1.0D0) GO TO 40
      N = MAX (ALNEPS/LOG(Y), 4.0D0)
      DO 30 I=1,N
        XI = I
        TERM = TERM * (XI-PS)*Y/XI
        DBETAI = DBETAI + TERM/(P+XI)
 30   CONTINUE
C
C NOW EVALUATE THE FINITE SUM, MAYBE.
C
 40   IF (Q.LE.1.0D0) GO TO 70
C
      XB = P*LOG(Y) + Q*LOG(1.0D0-Y) - DLBETA(P,Q) - LOG(Q)
      IB = MAX (XB/ALNSML, 0.0D0)
      TERM = EXP(XB - IB*ALNSML)
      C = 1.0D0/(1.D0-Y)
      P1 = Q*C/(P+Q-1.D0)
C
      FINSUM = 0.0D0
      N = Q
      IF (Q.EQ.DBLE(N)) N = N - 1
      DO 50 I=1,N
        IF (P1.LE.1.0D0 .AND. TERM/EPS.LE.FINSUM) GO TO 60
        XI = I
        TERM = (Q-XI+1.0D0)*C*TERM/(P+Q-XI)
C
        IF (TERM.GT.1.0D0) IB = IB - 1
        IF (TERM.GT.1.0D0) TERM = TERM*SML
C
        IF (IB.EQ.0) FINSUM = FINSUM + TERM
 50   CONTINUE
C
 60   DBETAI = DBETAI + FINSUM
 70   IF (Y.NE.X .OR. P.NE.PIN) DBETAI = 1.0D0 - DBETAI
      DBETAI = MAX (MIN (DBETAI, 1.0D0), 0.0D0)
      RETURN
C
 80   DBETAI = 0.0D0
      XB = P*LOG(MAX(Y,SML)) - LOG(P) - DLBETA(P,Q)
      IF (XB.GT.ALNSML .AND. Y.NE.0.0D0) DBETAI = EXP(XB)
      IF (Y.NE.X .OR. P.NE.PIN) DBETAI = 1.0D0 - DBETAI
C
      RETURN
      END


      SUBROUTINE convert_boundary_PG(rbc, zbs, rhobc, mpol, ntor)
      USE stel_kinds
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER, INTENT(in) :: mpol, ntor
      REAL(rprec), DIMENSION(-ntor:ntor,0:mpol) ::
     1   rbc, zbs
      REAL(rprec), DIMENSION(-ntor:ntor,-mpol:mpol), INTENT(out) ::
     1   rhobc
      REAL(rprec) :: rnorm, r00
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
      INTEGER, PARAMETER :: pexp = 4
      INTEGER :: mcount, ncount, m_bdy, n_bdy
      REAL(rprec), PARAMETER :: p25 = 0.25_dp, p50 = 0.50_dp,
     1                          zero = 0, one = 1
!-----------------------------------------------
!
!     GIVEN A BOUNDARY REPRESENTATION OF THE FORM
!
!     R = RBC(n,m)*COS(mu-nv)
!     Z = ZBS(n,m)*SIN(mu-nv)
!
!
!     CONVERT TO GARABEDIAN DELTA REPRESENTATION
!
      m_bdy = 0
      n_bdy = 0
      DO mcount = 0, mpol
         DO ncount = -ntor, ntor
            IF (rbc(ncount,mcount).ne.zero .or.
     1          zbs(ncount,mcount).ne.zero) THEN
                m_bdy = MAX(m_bdy,mcount)
                n_bdy = MAX(n_bdy,ABS(ncount))
            END IF
         END DO
      END DO

      IF(m_bdy+1 .gt. mpol) THEN
      WRITE(6,*) "In Conversion to Delta-mn, mpol too small"
      STOP
      END IF

      rhobc = zero
      r00 = rbc(0,0)
      rnorm = rbc(0,1)+zbs(0,1)
      rnorm = 2/rnorm

      DO mcount = 0, mpol
         DO ncount = -ntor, ntor
            rbc(ncount,mcount)=rbc(ncount,mcount)*rnorm
            zbs(ncount,mcount)=zbs(ncount,mcount)*rnorm
         END DO
      END DO

       DO mcount = 0, m_bdy
       DO ncount = -n_bdy, n_bdy
         rhobc(ncount,mcount+1) =
     >                  0.5*(rbc(ncount,mcount)-zbs(ncount,mcount))
     >                + rhobc(ncount,mcount+1)
         rhobc(-ncount,-mcount+1) =
     >                  0.5*(rbc(ncount,mcount)+zbs(ncount,mcount))
     >                + rhobc(-ncount,-mcount+1)
       END DO
       END DO
!
!      restore r(0,0) and keep fixed
!
       rhobc(0,0) = r00

      END SUBROUTINE convert_boundary_PG


!!
!! LaVeque Limit-choice routine
!!
!     =====================================================
!     # Apply a limiter to the waves.
!     # The limiter is computed by comparing the 2-norm of each wave with
!     # the projection of the wave from the interface to the left or
!     # right onto the current wave.  For a linear system this would
!     # correspond to comparing the norms of the two waves.  For a
!     # nonlinear problem the eigenvectors are not colinear and so the
!     # projection is needed to provide more limiting in the case where the
!     # neighboring wave has large norm but points in a different direction
!     # in phase space.
!
!     # The specific limiter used in each family is determined by the
!     # value of the corresponding element of the array mthlim, as used in
!     # the function philim.
!     # Note that a different limiter may be used in each wave family.
!
!     # dotl and dotr denote the inner product of wave with the wave to
!     # the left or right.  The norm of the projections onto the wave are then
!     # given by dotl/wnorm2 and dotr/wnorm2, where wnorm2 is the 2-norm
!     # of wave.
!
subroutine limiter(maxm,num_eqn,num_waves,num_ghost,mx,wave,s,mthlim)
!
!
!         mthlim(mw) = 0 for no limiter
!                    = 1 for minmod
!                    = 2 for superbee
!                    = 3 for van Leer
!                    = 4 for monotonized centered
    implicit none

    ! Arguments
    integer, intent(in) :: maxm, num_eqn, num_waves, num_ghost, mx
    real(kind=8), intent(in out) :: wave(num_eqn, num_waves, 1-num_ghost:maxm+num_ghost)
    real(kind=8), intent(in) :: s(num_waves, 1-num_ghost:maxm+num_ghost)
    integer, intent(in) :: mthlim(num_waves)

    ! Local storage
    integer :: m, mw, i
    real(kind=8) :: r, c, wlimiter, wnorm2, dotl
    real(kind=8), dimension(num_waves) :: dotr

    dotr = 0.d0

    x_loop: do i = 0, mx!+1

        wave_loop: do mw=1,num_waves
            if (mthlim(mw) == 0) then
                cycle wave_loop
            endif

            ! Construct dot products
            wnorm2 = 0.d0
            dotl = dotr(mw)
            dotr(mw) = 0.d0
            do m=1,num_eqn
                wnorm2 = wnorm2 + wave(m,mw,i)**2
                dotr(mw) = dotr(mw) + wave(m,mw,i)*wave(m,mw,i+1)
            end do

            ! Skip this loop if it's on the boundary or the size of the wave is
            ! zero (but still want dot products to be initialized above)
            if (i == 0) cycle wave_loop
            if (wnorm2 == 0.d0) cycle wave_loop

            ! Compute ratio of this wave's strength to upwind wave's strength
            if (s(mw,i) > 0.d0) then
                r = dotl / wnorm2
            else
                r = dotr(mw) / wnorm2
            endif

            ! Compute value of limiter function
            select case(mthlim(mw))

                ! Minmod
                case(1)
                    wlimiter = max(0.d0, min(1.d0, r))

                ! Superbee
                case(2)
                    wlimiter = max(0.d0, min(1.d0, 2.d0*r), min(2.d0, r))

                ! Van Leer
                case(3)
                    wlimiter = (r + abs(r)) / (1.d0 + abs(r))

                ! Monotonized - Centered
                case(4)
                    c = (1.d0 + r)/2.d0
                    wlimiter = max(0.d0, min(c, 2.d0, 2.d0*r))

                ! Beam Warming
                case(5)
                    wlimiter = r

                case default
                    stop "Invalid limiter method."

            end select

            ! Apply resulting limit
            wave(:,mw,i) = wlimiter * wave(:,mw,i)

        end do wave_loop
    end do x_loop

end subroutine limiter


Subroutine RMS(F,F0,Ip,Jp,rmsf)
implicit none
integer i,j,Ip,Jp
real(8) rmsf,F(Ip,Jp),F0(Ip,Jp),res(Ip,Jp)
DO j=1,Jp
 DO i=1,Ip
 if(abs(F0(i,j))>0) then
  res(i,j)=abs((F(i,j)-F0(i,j))/F0(i,j))
 else
  res(i,j)=abs(F(i,j)-F0(i,j))
 end if
 end DO
end DO
rmsf=sum(res)/(Ip*Jp)
end Subroutine RMS


module derivative_mod_gpu
    use cudafor
    implicit none
    contains

        attributes(global) subroutine derivative_gpu_kernel(u,du,n1, n2, n3,factors)
        !! divergence_mod :
        !! Compute the divergence using mod function to access neighbours on boundaries.
        !! The memory access on boundaries in not-contigous.
        real*8::u(-1:n1+2,-1:n2+2,-1:n3+2)
        real*8::du(n1,n2,n3),factors(5)
        integer, value, intent(in) :: n1, n2, n3

        integer  :: i, j,k, l, xn(5),yn(5),zn(5)
        real*8 :: ux(5), uy(5), uz(5)

        i = (blockIdx%x-1) * blockDim%x + threadIdx%x
        j = (blockIdx%y-1) * blockDim%y + threadIdx%y
        k = (blockIdx%z-1) * blockDim%z + threadIdx%z

!!        print *,i,j,k

        do l = -2, 2
            xn(l+3) = mod(i+l+n1-1,n1) + 1
            yn(l+3) = mod(j+l+n2-1,n2) + 1
            zn(l+3) = mod(k+l+n3-1,n3) + 1
        end do

        ux = u(xn,j,k)
        uy = u(i,yn,k)
        uz = u(i,j,zn)

        du(i,j,k) = (ux(1)+uy(1)+uz(1))*factors(1) &
                    + (ux(2)+uy(2)+uz(2))*factors(2) &
                    + (ux(3)+uy(3)+uz(3))*factors(3) &
                    + (ux(4)+uy(4)+uz(4))*factors(4) &
                    + (ux(5)+uy(5)+uz(5))*factors(5)
    end subroutine derivative_gpu_kernel

        subroutine derivative_gpu_dev(u,du,n1,n2,n3,factors)
                integer,value,intent(in)::n1,n2,n3
                real*8::u(-1:n1+2,-1:n2+2,-1:n3+2)
                real*8::du(n1,n2,n3),factors(5)
                integer::block_size(3)
                type(dim3) :: grid_sp,block_sp
                block_size(1)=32;block_size(2)=4;block_size(3)=4
                block_sp   = dim3(block_size(1),block_size(2),block_size(3))
                grid_sp    = dim3(n1/block_sp%x,n2/block_sp%y,n3/block_sp%z)
                !$acc host_data use_device(u,du,factors)
                !!$acc data present(u,du,factors)
                call derivative_gpu_kernel<<<grid_sp,block_sp>>>(u,du,n1,n2,n3,factors)
!! CHECK THIS::                call cuda_get_last_error()
                !$acc wait
                !!$acc end data
                !$acc end host_data
        end subroutine derivative_gpu_dev

end module derivative_mod_gpu


	SUBROUTINE PRELRISK
     . (XALPHA,POWER,XP0,XN,XPHI,resultP1L,resultP1H,resultRL,resultRH)
!MS$ATTRIBUTES REFERENCE :: resultP1L
!MS$ATTRIBUTES REFERENCE :: resultP1H
!MS$ATTRIBUTES REFERENCE :: resultRL
!MS$ATTRIBUTES REFERENCE :: resultRH
	IMPLICIT NONE

	REAL XALPHA,POWER,XP0,XN,XPHI,resultP1L
	REAL resultP1H,resultRL,resultRH
C
C-Description-----------------------------------------------------------
C
C  Function:
C	Relative risk calculations for paired prospective studies with
C	dichotomous outcomes.
C
C  Input (provided by user):
C	ALPHA	Type I error probability for a two sided test
C	POWER	The desired statistical power
C	P0		Event rate among controls
C	N		Number of pairs of patients
C	PHI		correlation coefficient for failure between paired subjects
C
C  Output:
C	R		Relative risk of experimental subjects relative to controls
C			(R=P1/P0) that can be detected with power POWER given
C			N pairs of subjects and a type I error probability ALPHA
C	P1		Event rate amoung experimental subjects
C
C  Notes:
C   .	This routine was written by Dale Plummer.
C		Designed by William Dupont.
C   .	Reference:
C	    Schlesselman, JJ:  "Case-Control Studies:  Design, Conduct,
C	    Analysis", New York:  Oxford U. Press 1982
C	See also:
C	    Dupont, WD: "Power Calculations for Matched Case-Control
C	    Studies", Biometrics, 1988; 44:1157-1168
C
C-Declarations----------------------------------------------------------
C
C
C  Function to be solved iteratively.
C
	EXTERNAL PFUNC1
	REAL PFUNC1
C
C  Locals
C
	INTEGER ERRORL,ERRORH
	REAL E1,EPS,Y1,Y2
C
C    Common to pass data to function.
C
	REAL ALPHA,BETA,N,P0,PHI_V,ZALPHA,ZBETA
	COMMON/PCOM/ALPHA,BETA,N,P0,PHI_V,ZALPHA,ZBETA
C
C-Code------------------------------------------------------------------
C
C	Copy arguments into common storage.
C
	ALPHA=XALPHA
	N=XN
	P0=XP0
	PHI_V=XPHI
	BETA=1.-POWER
C
C    Set error tolerance values.
C
	EPS=.0001*MIN(P0,1.-P0)
	E1=.0001*MIN(P0,1.-P0)
C
C    Set initial end points for lower end point.
C
	Y1=0.0
	Y2=P0-EPS
C
C    Solve the equation for the lower solution.
C
	CALL BISEC(Y1,Y2,EPS,E1,PFUNC1,resultP1L,ERRORL)
C
C    Calculate the relative risk.
C
	resultRL=resultP1L/P0
C
C    Set initial end points for high end point.
C
	Y1=P0+EPS
	Y2=1.
C
C    Solve the equation for the upper solution.
C
	CALL BISEC(Y1,Y2,EPS,E1,PFUNC1,resultP1H,ERRORH)
C
C    Calculate the relative risk.
C
	resultRH=resultP1H/P0
C
C  Done.
C
	RETURN
	END


      subroutine cli_slrgen(iwgn)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine generates solar radiation

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    hru_rmx(:)  |MJ/m^2        |maximum possible radiation for the day in HRU
!!    j           |none          |HRU number
!!    pr_w(3,:,:) |none          |proportion of wet days in a month
!!    wgncur(3,:) |none          |parameter which predicts impact of precip on
!!                               |daily solar radiation
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    hru_ra(:)   |MJ/m^2        |solar radiation for the day in HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use hydrograph_module
      use climate_module

      implicit none

      real :: rx                     !none          |variable to hold intermediate calculation
      real ::  rav                   !MJ/m^2        |modified monthly average solar radiation
      integer :: iwgn                !              |

      rav = wgn(iwgn)%solarav(time%mo) / (1. - 0.5 * wgn_pms(iwgn)%pr_wdays(time%mo))
      if (wst(iwst)%weat%precip > 0.0) rav = 0.5 * rav
      rx = wst(iwst)%weat%solradmx - rav
      wst(iwst)%weat%solrad = rav + wgncur(3,iwgn) * rx / 4.
      if (wst(iwst)%weat%solrad <= 0.) wst(iwst)%weat%solrad = .05 * wst(iwst)%weat%solradmx

      wst(iwst)%weat%solrad = wgn(iwgn)%solarav(time%mo)
      return
      end subroutine cli_slrgen


      SUBROUTINE WF_MA2
     &          (z1,z2,z3,out)

      real     *  8 out(6)
      complex  * 16 z1,z2,z3,temp

      temp=z1
      if (ABS(temp) .eq. 0.d0) then
         out(1)=-99.
         out(2)=0.d0
      else
         temp=LOG(temp)
         out(1)=EXP(DREAL(temp))
         out(2)=DIMAG(temp)
      end if
      temp=z2
      if (ABS(temp) .eq. 0.d0) then
         out(3)=-99.
         out(4)=0.d0
      else
         temp=LOG(temp)
         out(3)=EXP(DREAL(temp))
         out(4)=DIMAG(temp)
      end if
      temp=z3
      if (ABS(temp) .eq. 0.d0) then
         out(5)=-99.
         out(6)=0.d0
      else
         temp=LOG(temp)
         out(5)=EXP(DREAL(temp))
         out(6)=DIMAG(temp)
      end if
      RETURN
      END      ! WF_MA2