<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
<HTML><HEAD>
<META http-equiv=Content-Type content="text/html; charset=windows-1252"></HEAD>
<BODY><PRE>      REAL*8 FUNCTION PRAXIS(T0,MACHEP,H0,N,PRIN,X,F,FMIN)
C                             LAST MODIFIED 3/1/73
      REAL*8 T0,MACHEP,H0,X(N),F,FMIN
      EXTERNAL F
      INTEGER PRIN
C
C     PRAXIS RETURNS THE MINIMUM OF THE FUNCTION F(X,N) OF N VARIABLES
C     USING THE PRINCIPAL AXIS METHOD.  THE GRADIENT OF THE FUNCTION IS
C     NOT REQUIRED.
C
C     FOR A DESCRIPTION OF THE ALGORITHM, SEE CHAPTER SEVEN OF
C     "ALGORITHMS FOR FINDING ZEROS AND EXTREMA OF FUNCTIONS WITHOUT
C     CALCULATING DERIVATIVES" BY RICHARD P BRENT.
C
C     THE PARAMETERS ARE:
C     T0       IS A TOLERANCE.  PRAXIS ATTEMPTS TO RETURN PRAXIS=F(X)
C              SUCH THAT IF X0 IS THE TRUE LOCAL MINIMUM NEAR X, THEN
C              NORM(X-X0) < T0 + SQUAREROOT(MACHEP)*NORM(X).
C     MACHEP   IS THE MACHINE PRECISION, THE SMALLEST NUMBER SUCH THAT
C              1 + MACHEP > 1.  MACHEP SHOULD BE 16.**-13 (ABOUT
C              2.22D-16) FOR REAL*8 ARITHMETIC ON THE IBM 360.
C     H0       IS THE MAXIMUM STEP SIZE.  H0 SHOULD BE SET TO ABOUT THE
C              MAXIMUM DISTANCE FROM THE INITIAL GUESS TO THE MINIMUM.
C              (IF H0 IS SET TOO LARGE OR TOO SMALL, THE INITIAL RATE OF
C              CONVERGENCE MAY BE SLOW.)
C     N        (AT LEAST TWO) IS THE NUMBER OF VARIABLES UPON WHICH
C              THE FUNCTION DEPENDS.
C     PRIN     CONTROLS THE PRINTING OF INTERMEDIATE RESULTS.
C              IF PRIN=0, NOTHING IS PRINTED.
C              IF PRIN=1, F IS PRINTED AFTER EVERY N+1 OR N+2 LINEAR
C              MINIMIZATIONS.  FINAL X IS PRINTED, BUT INTERMEDIATE X IS
C              PRINTED ONLY IF N IS AT MOST 4.
C              IF PRIN=2, THE SCALE FACTORS AND THE PRINCIPAL VALUES OF
C              THE APPROXIMATING QUADRATIC FORM ARE ALSO PRINTED.
C              IF PRIN=3, X IS ALSO PRINTED AFTER EVERY FEW LINEAR
C              MINIMIZATIONS.
C              IF PRIN=4, THE PRINCIPAL VECTORS OF THE APPROXIMATING
C              QUADRATIC FORM ARE ALSO PRINTED.
C     X        IS AN ARRAY CONTAINING ON ENTRY A GUESS OF THE POINT OF
C              MINIMUM, ON RETURN THE ESTIMATED POINT OF MINIMUM.
C     F(X,N)   IS THE FUNCTION TO BE MINIMIZED.  F SHOULD BE A REAL*8
C              FUNCTION DECLARED EXTERNAL IN THE CALLING PROGRAM.
C     FMIN     IS AN ESTIMATE OF THE MINIMUM, USED ONLY IN PRINTING
C              INTERMEDIATE RESULTS.
C     THE APPROXIMATING QUADRATIC FORM IS
C              Q(X') = F(X,N) + (1/2) * (X'-X)-TRANSPOSE * A * (X'-X)
C     WHERE X IS THE BEST ESTIMATE OF THE MINIMUM AND A IS
C              INVERSE(V-TRANSPOSE) * D * INVERSE(V)
C     (V(*,*) IS THE MATRIX OF SEARCH DIRECTIONS; D(*) IS THE ARRAY
C     OF SECOND DIFFERENCES).  IF F HAS CONTINUOUS SECOND DERIVATIVES
C     NEAR X0, A WILL TEND TO THE HESSIAN OF F AT X0 AS X APPROACHES X0.
C
C     IT IS ASSUMED THAT ON FLOATING-POINT UNDERFLOW THE RESULT IS SET
C     TO ZERO.
C     THE USER SHOULD OBSERVE THE COMMENT ON HEURISTIC NUMBERS AFTER
C     THE INITIALIZATION OF MACHINE DEPENDENT NUMBERS.
C
      LOGICAL ILLC
      INTEGER NL,NF,KL,KT,KTM
      REAL*8 S,SL,DN,DMIN,FX,F1,LDS,LDT,T,H,SF,DF,QF1,QD0,QD1,QA,QB,QC
      REAL*8 M2,M4,SMALL,VSMALL,LARGE,VLARGE,SCBD,LDFAC,T2,DNI,VALUE
      REAL*8 RANDOM,DSQRT,DABS
C
C.....IF N>20 OR IF N<20 AND YOU NEED MORE SPACE, CHANGE '20' TO THE
C     LARGEST VALUE OF N IN THE NEXT CARD, IN THE CARD 'IDIM=20', AND
C     IN THE DIMENSION STATEMENTS IN SUBROUTINES MINFIT,MIN,FLIN,QUAD.
C
      REAL*8 D(20),Y(20),Z(20),Q0(20),Q1(20),V(20,20)
      COMMON /GLOBAL/ FX,LDT,DMIN,NF,NL
     .       /Q/ V,Q0,Q1,QA,QB,QC,QD0,QD1,QF1
C
C.....INITIALIZATION.....
C     MACHINE DEPENDENT NUMBERS:
C
      SMALL=MACHEP*MACHEP
      VSMALL=SMALL*SMALL
      LARGE=1.D0/SMALL
      VLARGE=1.D0/VSMALL
      M2=DSQRT(MACHEP)
      M4=DSQRT(M2)
C
C     HEURISTIC NUMBERS:
C     IF THE AXES MAY BE BADLY SCALED (WHICH IS TO BE AVOIDED IF
C     POSSIBLE), THEN SET SCBD=10.  OTHERWISE SET SCBD=1.
C     IF THE PROBLEM IS KNOWN TO BE ILL-CONDITIONED, SET ILLC=TRUE.
C     OTHERWISE SET ILLC=FALSE.
C     KTM IS THE NUMBER OF ITERATIONS WITHOUT IMPROVEMENT BEFORE THE
C     ALGORITHM TERMINATES.  KTM=4 IS VERY CAUTIOUS; USUALLY KTM=1
C     IS SATISFACTORY.
C
      SCBD=1.D0
      ILLC=.FALSE.
      KTM=1
C
      LDFAC=0.01D0
      IF (ILLC) LDFAC=0.1D0
      KT=0
      NL=0
      NF=1
      FX=F(X,N)
      QF1=FX
      T=SMALL+DABS(T0)
      T2=T
      DMIN=SMALL
      H=H0
      IF (H.LT.100*T) H=100*T
      LDT=H
C.....THE FIRST SET OF SEARCH DIRECTIONS V IS THE IDENTITY MATRIX.....
      DO 20 I=1,N
           DO 10 J=1,N
10              V(I,J)=0.0D0
20         V(I,I)=1.D0
      D(1)=0.D0
      QD0=0.D0
      DO 30 I=1,N
           Q0(I)=X(I)
30         Q1(I)=X(I)
      IF (PRIN.GT.0) CALL PRINT(N,X,PRIN,FMIN)
C
C.....THE MAIN LOOP STARTS HERE.....
40    SF=D(1)
      D(1)=0.D0
      S=0.D0
C
C.....MINIMIZE ALONG THE FIRST DIRECTION V(*,1).
C     FX MUST BE PASSED TO MIN BY VALUE.
      VALUE=FX
      CALL MIN(N,1,2,D(1),S,VALUE,.FALSE.,F,X,T,MACHEP,H)
      IF (S.GT.0.D0) GO TO 50
           DO 45 I=1,N
45              V(I,1)=-V(I,1)
50    IF (SF.GT.0.9D0*D(1).AND.0.9D0*SF.LT.D(1)) GO TO 70
           DO 60 I=2,N
60              D(I)=0.D0
C
C.....THE INNER LOOP STARTS HERE.....
70    DO 170 K=2,N
           DO 75 I=1,N
75              Y(I)=X(I)
           SF=FX
           IF (KT.GT.0) ILLC=.TRUE.
80         KL=K
           DF=0.D0
C
C.....A RANDOM STEP FOLLOWS (TO AVOID RESOLUTION VALLEYS).
C     PRAXIS ASSUMES THAT RANDOM RETURNS A RANDOM NUMBER UNIFORMLY
C     DISTRIBUTED IN (0,1).
C
           IF(.NOT.ILLC) GO TO 95
                DO 90 I=1,N
                     S=(0.1D0*LDT+T2*(10**KT))*(RANDOM(N)-0.5D0)
                     Z(I)=S
                     DO 85 J=1,N
85                        X(J)=X(J)+S*V(J,I)
90              CONTINUE
                FX=F(X,N)
                NF=NF+1
C
C.....MINIMIZE ALONG THE "NON-CONJUGATE" DIRECTIONS V(*,K),...,V(*,N)
C
95         DO 105 K2=K,N
                SL=FX
                S=0.D0
                VALUE=FX
                CALL MIN(N,K2,2,D(K2),S,VALUE,.FALSE.,F,X,T,MACHEP,H)
                IF (ILLC) GO TO 97
                     S=SL-FX
                     GO TO 99
97              S=D(K2)*((S+Z(K2))**2)
99              IF (DF.GT.S) GO TO 105
                     DF=S
                     KL=K2
105        CONTINUE
           IF (ILLC.OR.(DF.GE.DABS((100*MACHEP)*FX))) GO TO 110
C
C.....IF THERE WAS NOT MUCH IMPROVEMENT ON THE FIRST TRY, SET
C     ILLC=TRUE AND START THE INNER LOOP AGAIN.....
C
           ILLC=.TRUE.
           GO TO 80
110        IF (K.EQ.2.AND.PRIN.GT.1) CALL VCPRNT(1,D,N)
C
C.....MINIMIZE ALONG THE "CONJUGATE" DIRECTIONS V(*,1),...,V(*,K-1)
C
           KM1=K-1
           DO 120 K2=1,KM1
           S=0
           VALUE=FX
           CALL MIN(N,K2,2,D(K2),S,VALUE,.FALSE.,F,X,T,MACHEP,H)
120        CONTINUE
           F1=FX
           FX=SF
           LDS=0
           DO 130 I=1,N
                SL=X(I)
                X(I)=Y(I)
                SL=SL-Y(I)
                Y(I)=SL
130             LDS=LDS+SL*SL
           LDS=DSQRT(LDS)
           IF (LDS.LE.SMALL) GO TO 160
C
C.....DISCARD DIRECTION V(*,KL).
C     IF NO RANDOM STEP WAS TAKEN, V(*,KL) IS THE "NON-CONJUGATE"
C     DIRECTION ALONG WHICH THE GREATEST IMPROVEMENT WAS MADE.....
C
           KLMK=KL-K
           IF (KLMK.LT.1) GO TO 141
           DO 140 II=1,KLMK
                I=KL-II
                DO 135 J=1,N
135                  V(J,I+1)=V(J,I)
140             D(I+1)=D(I)
141        D(K)=0
           DO 145 I=1,N
145             V(I,K)=Y(I)/LDS
C
C.....MINIMIZE ALONG THE NEW "CONJUGATE" DIRECTION V(*,K), WHICH IS
C     THE NORMALIZED VECTOR:  (NEW X) - (0LD X).....
C
           VALUE=F1
           CALL MIN(N,K,4,D(K),LDS,VALUE,.TRUE.,F,X,T,MACHEP,H)
           IF (LDS.GT.0.D0) GO TO 160
                LDS=-LDS
                DO 150 I=1,N
150                  V(I,K)=-V(I,K)
160        LDT=LDFAC*LDT
           IF (LDT.LT.LDS) LDT=LDS
           IF (PRIN.GT.0) CALL PRINT(N,X,PRIN,FMIN)
           T2=0.D0
           DO 165 I=1,N
165             T2=T2+X(I)**2
           T2=M2*DSQRT(T2)+T
C
C.....SEE WHETHER THE LENGTH OF THE STEP TAKEN SINCE STARTING THE
C     INNER LOOP EXCEEDS HALF THE TOLERANCE.....
C
           IF (LDT.GT.(0.5*T2)) KT=-1
           KT=KT+1
           IF (KT.GT.KTM) GO TO 400
170   CONTINUE
C.....THE INNER LOOP ENDS HERE.
C
C     TRY QUADRATIC EXTRAPOLATION IN CASE WE ARE IN A CURVED VALLEY.
C
171   CALL QUAD(N,F,X,T,MACHEP,H)
      DN=0.D0
      DO 175 I=1,N
           D(I)=1.D0/DSQRT(D(I))
           IF (DN.LT.D(I)) DN=D(I)
175   CONTINUE
      IF (PRIN.GT.3) CALL MAPRNT(1,V,IDIM,N)
      DO 180 J=1,N
           S=D(J)/DN
           DO 180 I=1,N
180             V(I,J)=S*V(I,J)
C
C.....SCALE THE AXES TO TRY TO REDUCE THE CONDITION NUMBER.....
C
      IF (SCBD.LE.1.D0) GO TO 200
           S=VLARGE
           DO 185 I=1,N
                SL=0.D0
                DO 182 J=1,N
182                  SL=SL+V(I,J)*V(I,J)
                Z(I)=DSQRT(SL)
                IF (Z(I).LT.M4) Z(I)=M4
                IF (S.GT.Z(I)) S=Z(I)
185        CONTINUE
           DO 195 I=1,N
                SL=S/Z(I)
                Z(I)=1.D0/SL
                IF (Z(I).LE.SCBD) GO TO 189
                     SL=1.D0/SCBD
                     Z(I)=SCBD
189             DO 190 J=1,N
190                  V(I,J)=SL*V(I,J)
195        CONTINUE
C
C.....CALCULATE A NEW SET OF ORTHOGONAL DIRECTIONS BEFORE REPEATING
C     THE MAIN LOOP.
C     FIRST TRANSPOSE V FOR MINFIT:
C
200   DO 220 I=2,N
           IM1=I-1
           DO 210 J=1,IM1
                S=V(I,J)
                V(I,J)=V(J,I)
210             V(J,I)=S
220   CONTINUE
C
C.....CALL MINFIT TO FIND THE SINGULAR VALUE DECOMPOSITION OF V.
C     THIS GIVES THE PRINCIPAL VALUES AND PRINCIPAL DIRECTIONS OF THE
C     APPROXIMATING QUADRATIC FORM WITHOUT SQUARING THE CONDITION
C     NUMBER.....
C
      CALL MINFIT(IDIM,N,MACHEP,VSMALL,V,D)
C
C.....UNSCALE THE AXES.....
C
      IF (SCBD.LE.1.D0) GO TO 250
           DO 230 I=1,N
                S=Z(I)
                DO 225 J=1,N
225                  V(I,J)=S*V(I,J)
230        CONTINUE
           DO 245 I=1,N
                S=0.D0
                DO 235 J=1,N
235                  S=S+V(J,I)**2
                S=DSQRT(S)
                D(I)=S*D(I)
                S=1/S
                DO 240 J=1,N
240                  V(J,I)=S*V(J,I)
245        CONTINUE
C
250   DO 270 I=1,N
           DNI=DN*D(I)
           IF (DNI.GT.LARGE) GO TO 265
                IF (DNI.LT.SMALL) GO TO 260
                     D(I)=1/(DNI*DNI)
                     GO TO 270
260             D(I)=VLARGE
                GO TO 270
265        D(I)=VSMALL
270   CONTINUE
C
C.....SORT THE EIGENVALUES AND EIGENVECTORS.....
C
      CALL SORT(IDIM,N,D,V)
      DMIN=D(N)
      IF (DMIN.LT.SMALL) DMIN=SMALL
      ILLC=.FALSE.
      IF (M2*D(1).GT.DMIN) ILLC=.TRUE.
      IF (PRIN.GT.1.AND.SCBD.GT.1.D0) CALL VCPRNT(2,Z,N)
      IF (PRIN.GT.1) CALL VCPRNT(3,D,N)
      IF (PRIN.GT.3) CALL MAPRNT(2,V,IDIM,N)
C.....THE MAIN LOOP ENDS HERE.....
C
      GO TO 40
C
C.....RETURN.....
C
400   IF (PRIN.GT.0) CALL VCPRNT(4,X,N)
      PRAXIS=FX
      RETURN
      END
      SUBROUTINE MINFIT(M,N,MACHEP,TOL,AB,Q)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 MACHEP
      DIMENSION AB(M,N),Q(N)
C...AN IMPROVED VERSION OF MINFIT (SEE GOLUB AND REINSCH, 1969)
C   RESTRICTED TO M=N,P=0.
C   THE SINGULAR VALUES OF THE ARRAY AB ARE RETURNED IN Q AND AB IS
C   OVERWRITTEN WITH THE ORTHOGONAL MATRIX V SUCH THAT U.DIAG(Q) = AB.V,
C   WHERE U IS ANOTHER ORTHOGONAL MATRIX.
      DIMENSION E(20)
C...HOUSEHOLDER'S REDUCTION TO BIDIAGONAL FORM...
      IF (N.EQ.1) GO TO 200
      EPS = MACHEP
      G = 0.D0
      X = 0.D0
      DO 11 I=1,N
         E(I) = G
         S = 0.D0
         L = I + 1
         DO 1 J=I,N
1           S = S + AB(J,I)**2
         G = 0.D0
         IF (S.LT.TOL) GO TO 4
            F = AB(I,I)
            G = DSQRT(S)
            IF (F.GE.0.D0) G = -G
            H = F*G - S
            AB(I,I)=F-G
            IF (L.GT.N) GO TO 4
            DO 3 J=L,N
               F = 0.D0
               DO 2 K=I,N
2                 F = F + AB(K,I)*AB(K,J)
               F = F/H
               DO 3 K=I,N
3                 AB(K,J) = AB(K,J) + F*AB(K,I)
4        Q(I) = G
         S = 0.D0
         IF (I.EQ.N) GO TO 6
         DO 5 J=L,N
5           S = S + AB(I,J)*AB(I,J)
6        G = 0.D0
         IF (S.LT.TOL) GO TO 10
            IF (I.EQ.N) GO TO 16
            F = AB(I,I+1)
16          G = DSQRT(S)
            IF (F.GE.0.D0) G = -G
            H = F*G - S
            IF (I.EQ.N) GO TO 10
            AB(I,I+1) = F - G
            DO 7 J=L,N
7              E(J) = AB(I,J)/H
            DO 9 J=L,N
               S = 0.D0
               DO 8 K=L,N
8                 S = S + AB(J,K)*AB(I,K)
               DO 9 K=L,N
9                 AB(J,K) = AB(J,K) + S*E(K)
10       Y = DABS(Q(I)) + DABS(E(I))
11       IF (Y.GT.X) X = Y
C...ACCUMULATION OF RIGHT-HAND TRANSFORMATIONS...
      AB(N,N) = 1.D0
      G = E(N)
      L = N
      DO 25 II=2,N
         I = N - II + 1
         IF (G.EQ.0.D0) GO TO 23
         H = AB(I,I+1)*G
         DO 20 J=L,N
20          AB(J,I) = AB(I,J)/H
         DO 22 J=L,N
            S = 0.D0
            DO 21 K=L,N
21             S = S + AB(I,K)*AB(K,J)
            DO 22 K=L,N
22             AB(K,J) = AB(K,J) + S*AB(K,I)
23       DO 24 J=L,N
            AB(I,J) = 0.D0
24          AB(J,I) = 0.D0
         AB(I,I) = 1.D0
         G = E(I)
25       L = I
C...DIAGONALIZATION OF THE BIDIAGONAL FORM...
100   EPS = EPS*X
      DO 150 KK=1,N
         K = N - KK + 1
         KT = 0
101      KT = KT + 1
         IF (KT.LE.30) GO TO 102
            E(K) = 0.D0
            WRITE (6,1000)
1000        FORMAT (' QR FAILED')
102      DO 103 LL2=1,K
            L2 = K - LL2 + 1
            L = L2
            IF (DABS(E(L)).LE.EPS) GO TO 120
            IF (L.EQ.1) GO TO 103
            IF (DABS(Q(L-1)).LE.EPS) GO TO 110
103         CONTINUE
C...CANCELLATION OF E(L) IF L>1...
110      C = 0.D0
         S = 1.D0
         DO 116 I=L,K
            F = S*E(I)
            E(I) = C*E(I)
            IF (DABS(F).LE.EPS) GO TO 120
            G = Q(I)
C...Q(I) = H = DSQRT(G*G + F*F)...
            IF (DABS(F).LT.DABS(G)) GO TO 113
            IF (F) 112,111,112
111         H = 0.D0
            GO TO 114
112         H = DABS(F)*DSQRT(1 + (G/F)**2)
            GO TO 114
113         H = DABS(G)*DSQRT(1 + (F/G)**2)
114         Q(I) = H
            IF (H.NE.0.D0) GO TO 115
               G = 1.D0
               H = 1.D0
115         C = G/H
116         S = -F/H
C...TEST FOR CONVERGENCE...
120      Z = Q(K)
         IF (L.EQ.K) GO TO 140
C...SHIFT FROM BOTTOM 2*2 MINOR...
         X = Q(L)
         Y = Q(K-1)
         G = E(K-1)
         H = E(K)
         F = ((Y - Z)*(Y + Z) + (G - H)*(G + H))/(2*H*Y)
         G = DSQRT(F*F + 1.0D0)
         TEMP = F - G
         IF (F.GE.0.D0) TEMP = F + G
         F = ((X - Z)*(X + Z) + H*(Y/TEMP - H))/X
C...NEXT QR TRANSFORMATION...
         C = 1.D0
         S = 1.D0
         LP1 = L + 1
         IF (LP1.GT.K) GO TO 133
         DO 132 I=LP1,K
            G = E(I)
            Y = Q(I)
            H = S*G
            G = G*C
            IF (DABS(F).LT.DABS(H)) GO TO 123
            IF (F) 122,121,122
121         Z = 0.D0
            GO TO 124
122         Z = DABS(F)*DSQRT(1 + (H/F)**2)
            GO TO 124
123         Z = DABS(H)*DSQRT(1 + (F/H)**2)
124         E(I-1) = Z
            IF (Z.NE.0.D0) GO TO 125
               F = 1.D0
               Z = 1.D0
125         C = F/Z
            S = H/Z
            F = X*C + G*S
            G = -X*S + G*C
            H = Y*S
            Y = Y*C
            DO 126 J=1,N
               X = AB(J,I-1)
               Z = AB(J,I)
               AB(J,I-1) = X*C + Z*S
126            AB(J,I) = -X*S + Z*C
            IF (DABS(F).LT.DABS(H)) GO TO 129
            IF (F) 128,127,128
127         Z = 0.D0
            GO TO 130
128         Z = DABS(F)*DSQRT(1 + (H/F)**2)
            GO TO 130
129         Z = DABS(H)*DSQRT(1 + (F/H)**2)
130         Q(I-1) = Z
            IF (Z.NE.0.D0) GO TO 131
               F = 1.D0
               Z = 1.D0
131         C = F/Z
            S = H/Z
            F = C*G + S*Y
132         X = -S*G + C*Y
133      E(L) = 0.D0
         E(K) = F
         Q(K) = X
         GO TO 101
C...CONVERGENCE:  Q(K) IS MADE NON-NEGATIVE...
140      IF (Z.GE.0.D0) GO TO 150
         Q(K) = -Z
         DO 141 J=1,N
141         AB(J,K) = -AB(J,K)
150      CONTINUE
      RETURN
200   Q(1) = AB(1,1)
      AB(1,1) = 1.D0
      RETURN
      END
      SUBROUTINE MIN(N,J,NITS,D2,X1,F1,FK,F,X,T,MACHEP,H)
      IMPLICIT REAL*8 (A-H,O-Z)
      EXTERNAL F
      LOGICAL FK
      REAL*8 MACHEP,X(N),LDT
      DIMENSION V(20,20),Q0(20),Q1(20)
      COMMON /GLOBAL/ FX,LDT,DMIN,NF,NL
     .       /Q/ V,Q0,Q1,QA,QB,QC,QD0,QD1,QF1
C...THE SUBROUTINE MIN MINIMIZES F FROM X IN THE DIRECTION V(*,J) UNLESS
C   J IS LESS THAN 1, WHEN A QUADRATIC SEARCH IS MADE IN THE PLANE
C   DEFINED BY Q0,Q1,X.
C   D2 IS EITHER ZERO OR AN APPROXIMATION TO HALF F".
C   ON ENTRY, X1 IS AN ESTIMATE OF THE DISTANCE FROM X TO THE MINIMUM
C   ALONG V(*,J) (OR, IF J=0, A CURVE).  ON RETURN, X1 IS THE DISTANCE
C   FOUND.
C   IF FK=.TRUE., THEN F1 IS FLIN(X1).  OTHERWISE X1 AND F1 ARE IGNORED
C   ON ENTRY UNLESS FINAL FX IS GREATER THAN F1.
C   NITS CONTROLS THE NUMBER OF TIMES AN ATTEMPT WILL BE MADE TO HALVE
C   THE INTERVAL.
      LOGICAL DZ
      REAL*8 M2,M4
      SMALL = MACHEP**2
      M2 = DSQRT(MACHEP)
      M4 = DSQRT(M2)
      SF1 = F1
      SX1 = X1
      K = 0
      XM = 0.D0
      FM = FX
      F0 = FX
      DZ = D2.LT.MACHEP
C...FIND THE STEP SIZE...
      S = 0.D0
      DO 1 I=1,N
1        S = S + X(I)**2
      S = DSQRT(S)
      TEMP = D2
      IF (DZ) TEMP = DMIN
      T2 = M4*DSQRT(DABS(FX)/TEMP + S*LDT) + M2*LDT
      S = M4*S + T
      IF (DZ.AND.T2.GT.S) T2 = S
      T2 = DMAX1(T2,SMALL)
      T2 = DMIN1(T2,.01D0*H)
      IF (.NOT.FK.OR.F1.GT.FM) GO TO 2
      XM = X1
      FM = F1
2     IF (FK.AND.DABS(X1).GE.T2) GO TO 3
      TEMP=1.D0
      IF (X1.LT.0.D0) TEMP=-1.D0
      X1=TEMP*T2
      F1 = FLIN(N,J,X1,F,X,NF)
3     IF (F1.GT.FM) GO TO 4
      XM = X1
      FM = F1
4     IF (.NOT.DZ) GO TO 6
C...EVALUATE FLIN AT ANOTHER POINT AND ESTIMATE THE SECOND DERIVATIVE...
      X2 = -X1
      IF (F0.GE.F1) X2 = 2.D0*X1
      F2 = FLIN(N,J,X2,F,X,NF)
      IF (F2.GT.FM) GO TO 5
         XM = X2
         FM = F2
5     D2 = (X2*(F1 - F0)-X1*(F2 - F0))/((X1*X2)*(X1 - X2))
C...ESTIMATE THE FIRST DERIVATIVE AT 0...
6     D1 = (F1 - F0)/X1 - X1*D2
      DZ = .TRUE.
C...PREDICT THE MINIMUM...
      IF (D2.GT.SMALL) GO TO 7
         X2 = H
         IF (D1.GE.0.D0) X2 = -X2
         GO TO 8
7        X2 = (-.5D0*D1)/D2
8     IF (DABS(X2).LE.H) GO TO 11
         IF (X2) 9,9,10
9        X2 = -H
         GO TO 11
10       X2 = H
C...EVALUATE F AT THE PREDICTED MINIMUM...
11    F2 = FLIN(N,J,X2,F,X,NF)
      IF (K.GE.NITS.OR.F2.LE.F0) GO TO 12
C...NO SUCCESS, SO TRY AGAIN...
         K = K + 1
         IF (F0.LT.F1.AND.(X1*X2).GT.0.D0) GO TO 4
         X2 = 0.5D0*X2
         GO TO 11
C...INCREMENT THE ONE-DIMENSIONAL SEARCH COUNTER...
12    NL = NL + 1
      IF (F2.LE.FM) GO TO 13
      X2 = XM
      GO TO 14
13    FM = F2
C...GET A NEW ESTIMATE OF THE SECOND DERIVATIVE...
14    IF (DABS(X2*(X2 - X1)).LE.SMALL) GO TO 15
         D2 = (X2*(F1-F0) - X1*(FM-F0))/((X1*X2)*(X1 - X2))
         GO TO 16
15       IF (K.GT.0) D2 = 0.D0
16    IF (D2.LE.SMALL) D2 = SMALL
      X1 = X2
      FX = FM
      IF (SF1.GE.FX) GO TO 17
         FX = SF1
         X1 = SX1
C...UPDATE X FOR LINEAR BUT NOT PARABOLIC SEARCH...
17    IF (J.EQ.0) RETURN
      DO 18 I=1,N
18       X(I) = X(I) + X1*V(I,J)
      RETURN
      END
      REAL*8 FUNCTION FLIN (N,J,L,F,X,NF)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 L,X(N)
      DIMENSION V(20,20),Q0(20),Q1(20)
C...FLIN IS THE FUNCTION OF ONE REAL VARIABLE L THAT IS MINIMIZED
C   BY THE SUBROUTINE MIN...
      COMMON /Q/ V,Q0,Q1,QA,QB,QC,QD0,QD1,QF1
      DIMENSION T(20)
      IF (J .EQ. 0) GO TO 2
C...THE SEARCH IS LINEAR...
      DO 1 I=1,N
1        T(I) = X(I) + L*V(I,J)
      GO TO 4
C...THE SEARCH IS ALONG A PARABOLIC SPACE CURVE...
2     QA = (L*(L - QD1))/(QD0*(QD0 + QD1))
      QB = ((L + QD0)*(QD1 - L))/(QD0*QD1)
      QC = (L*(L + QD0))/(QD1*(QD0 + QD1))
      DO 3 I=1,N
3        T(I) = (QA*Q0(I) + QB*X(I)) + QC*Q1(I)
C...THE FUNCTION EVALUATION COUNTER NF IS INCREMENTED...
4     NF = NF + 1
      FLIN = F(T,N)
      RETURN
      END
      SUBROUTINE SORT(M,N,D,V)
      REAL*8 D(N),V(M,N)
C...SORTS THE ELEMENTS OF D(N) INTO DESCENDING ORDER AND MOVES THE
C   CORRESPONDING COLUMNS OF V(N,N).
C   M IS THE ROW DIMENSION OF V AS DECLARED IN THE CALLING PROGRAM.
      REAL*8 S
      IF (N.EQ.1) RETURN
      NM1 = N - 1
      DO 3 I = 1,NM1
         K=I
         S = D(I)
         IP1 = I + 1
         DO 1 J = IP1,N
            IF (D(J) .LE. S) GO TO 1
            K = J
            S = D(J)
1           CONTINUE
         IF (K .LE. I) GO TO 3
         D(K) = D(I)
         D(I) = S
         DO 2 J = 1,N
            S = V(J,I)
            V(J,I) = V(J,K)
2           V(J,K) = S
3        CONTINUE
      RETURN
      END
      SUBROUTINE QUAD(N,F,X,T,MACHEP,H)
      IMPLICIT REAL*8 (A-H,O-Z)
      EXTERNAL F
C...QUAD LOOKS FOR THE MINIMUM OF F ALONG A CURVE DEFINED BY Q0,Q1,X...
      REAL*8 X(N),MACHEP,LDT,L
      DIMENSION V(20,20),Q0(20),Q1(20)
      COMMON /GLOBAL/ FX,LDT,DMIN,NF,NL
     .       /Q/ V,Q0,Q1,QA,QB,QC,QD0,QD1,QF1
      S = FX
      FX = QF1
      QF1 = S
      QD1 = 0.D0
      DO 1 I=1,N
         S = X(I)
         L = Q1(I)
         X(I) = L
         Q1(I) = S
1        QD1 = QD1 + (S-L)**2
      QD1 = DSQRT(QD1)
      L = QD1
      S = 0.D0
      IF (QD0. LE. 0.D0 .OR. QD1 .LE. 0.D0 .OR. NL .LT. 3*N*N) GO TO 2
      VALUE=QF1
      CALL MIN(N,0,2,S,L,VALUE,.TRUE.,F,X,T,MACHEP,H)
      QA = (L*(L-QD1))/(QD0*(QD0+QD1))
      QB = ((L+QD0)*(QD1-L))/(QD0*QD1)
      QC = (L*(L+QD0))/(QD1*(QD0+QD1))
      GO TO 3
2     FX = QF1
      QA = 0.D0
      QB = QA
      QC = 1.D0
3     QD0 = QD1
      DO 4 I=1,N
         S = Q0(I)
         Q0(I) = X(I)
4        X(I) = (QA*S + QB*X(I)) + QC*Q1(I)
      RETURN
      END
      SUBROUTINE VCPRNT(OPTION,V,N)
      REAL*8 V(N)
      INTEGER OPTION
      GO TO (1,2,3,4),OPTION
1     WRITE (6,101) (V(I),I=1,N)
      RETURN
2     WRITE (6,102) (V(I),I=1,N)
      RETURN
3     WRITE (6,103) (V(I),I=1,N)
      RETURN
4     WRITE (6,104) (V(I),I=1,N)
      RETURN
101   FORMAT (/' THE SECOND DIFFERENCE ARRAY D(*) IS:'/
     .        (E32.14,4E25.14))
102   FORMAT (/' THE SCALE FACTORS ARE:'/(E32.14,4E25.14))
103   FORMAT (/' THE APPROXIMATING QUADRATIC FORM HAS THE PRINCIPAL VALU
     .ES:'/(E32.14,4E25.14))
104   FORMAT (/' X IS:',E26.14/(E32.14))
      END
      SUBROUTINE PRINT(N,X,PRIN,FMIN)
      IMPLICIT REAL*8 (A-H,O-Z)
      INTEGER PRIN
      REAL*8 X(N),LN,LDT
      COMMON /GLOBAL/ FX,LDT,DMIN,NF,NL
      WRITE (6,101) NL,NF,FX
      IF (FX.LE.FMIN) GO TO 1
      LN = DLOG10(FX-FMIN)
      WRITE (6,102) FMIN,LN
      GO TO 2
1     WRITE (6,103) FMIN
2     IF (N.GT.4.AND.PRIN.LE.2) RETURN
      WRITE (6,104) (X(I),I=1,N)
      RETURN
101   FORMAT (/' AFTER',I6,
     . ' LINEAR SEARCHES, THE FUNCTION HAS BEEN EVALUATED',I6,
     . ' TIMES.  THE SMALLEST VALUE FOUND IS F(X) = ',E21.14)
102   FORMAT (' LOG (F(X)-',E21.14,') = ',E21.14)
103   FORMAT (' LOG (F(X)-',E21.14,') IS UNDEFINED.')
104   FORMAT (' X IS:',E26.14/(E32.14))
      END
      SUBROUTINE MAPRNT(OPTION,V,M,N)
      REAL*8 V(M,N)
      INTEGER OPTION,LOW,UPP
C...THE SUBROUTINE MAPRNT PRINTS THE COLUMNS OF THE NXN MATRIX V
C   WITH A HEADING AS SPECIFIED BY OPTION.
C   M IS THE ROW DIMENSION OF V AS DECLARED IN THE CALLING PROGRAM...
      LOW = 1
      UPP = 5
      GO TO (1,2),OPTION
1     WRITE (6,101)
101   FORMAT (/' THE NEW DIRECTIONS ARE:')
      GO TO 3
2     WRITE (6,102)
102   FORMAT (' AND THE PRINCIPAL AXES:')
3     IF (N.LT.UPP) UPP = N
      DO 4 I=1,N
4        WRITE (6,104) (V(I,J),J=LOW,UPP)
      LOW = LOW + 5
      IF (N.LT.LOW) RETURN
      UPP = UPP + 5
      WRITE (6,103)
      GO TO 3
103   FORMAT (' ')
104   FORMAT (E32.14,4E25.14)
      END
      REAL*8 FUNCTION RANDOM(NAUGHT)
      REAL*8 RAN1,RAN3(127),HALF
      INTEGER RAN2,Q,R
      LOGICAL INIT
      DATA INIT/.FALSE./
      IF (INIT) GO TO 3
      R = MOD(NAUGHT,8190) + 1
      RAN2 = 128
      DO 2 I=1,127
         RAN2 = RAN2 - 1
         RAN1 = -2.D0**55
         DO 1 J=1,7
            R = MOD(1756*R,8191)
            Q = R/32
1           RAN1 = (RAN1 + Q)*(1.0D0/256)
2        RAN3(RAN2) = RAN1
      INIT = .TRUE.
3     IF (RAN2.EQ.1) RAN2 = 128
      RAN2 = RAN2 - 1
      RAN1 = RAN1 + RAN3(RAN2)
      HALF = .5D0
      IF (RAN1.GE.0.D0) HALF = -HALF
      RAN1 = RAN1 + HALF
      RAN3(RAN2) = RAN1
      RANDOM = RAN1 + .5D0
      RETURN
      END
</PRE></BODY></HTML>


module constants_module
      use precision_module, only : wp

      real(wp), parameter :: pi=3.1415926535897932d0
      real(wp), parameter :: planck = 4.1356676623401643d-15
      real(wp), parameter :: planck_hsec = 1.519829845d-16
      real(wp), parameter :: kb_hartK = 3.16681053d-6
      real(wp), parameter :: autocm = 219474.63137172544d0
      real(wp), parameter :: amutoau = 1822.8884853323708d0
      real(wp), parameter :: autoev = 27.21138602d0
      real(wp), parameter :: autokcalpermol = 627.50947377753740d0
      real(wp), parameter :: zero =  0.0d0
      real(wp), parameter :: one =   1.0d0
      real(wp), parameter :: two =   2.0d0
      real(wp), parameter :: three = 3.0d0
      real(wp), parameter :: four  = 4.0d0
      real(wp), parameter :: five  = 5.0d0
      real(wp), parameter :: half =  0.5d0
end module


program test_Voigt_av
!===============================================================================
!  Test the CIJ_Voigt_av subroutine

use anisotropy_ajn

implicit none

real(8) :: C(10,6,6),rh(10),VF(10)
real(8) :: CVoigt(6,6),rhVoigt
integer :: i

!  Set density to be the same for all values
rh = 5500.

!  Set equal weighting for all values--this will be normalised in the subroutine.
VF = 1.

!  Create 10 arrays filled with 1,2,3...10.  The Voigt average is an array filled
!  with the mean = (1+2+3+...+9+10)/10 = 5.5
do i=1,10
   C(i,:,:) = real(i)
enddo

call CIJ_Voigt_av(VF,C,rh,CVoigt,rhVoigt)

write(*,'(a)') '====== Testing CIJ_Voigt_av ======'
write(*,'(a)') 'Expected output:'
write(*,'(6(f4.1))') (5.5,i=1,36)
write(*,'(a)') ''
write(*,'(a)') 'Voigt average:'
write(*,'(6(f4.1))') CVoigt
write(*,'(a)') '=================================='

end program


!=====================================================================================================
! The subroutine calculates the distribution of a dencity and mass accretion rate over the radial coordinate
! in accretion disc.
! R_in, R_out - the inner and outer radii of accretion disc;
! R_ - the radial coordinate of initial distortion
! n - the coeffisient which describes the evolution of viscosity in accretion disc with the radius
! t - time in units of viscous time scale at R=1.
! n_root - the number of roots which we use to get numerical solution.
! n_R - the number of points over the radial coordinate ==!
!=====================================================================================================
subroutine TestGreenFun01(R_in,R_out,R_,n,t,n_root,n_R)
implicit none
real*8,intent(in)::R_in,R_out,R_,n,t
real*8::l,root,Sigma,Mdot,R,dR, x_in, x_out
dimension root(n_root)
integer,intent(in)::n_root
integer::n_R
  dR=(R_out-R_in)/(n_R-1)
  l=1.d0/(4.d0-2*n)
  x_out = 1.d0
  x_in = (R_in/R_out)**(1.d0-n/2.d0)
  call rootsLipunova(root,n_root,l,x_in,x_out)
  R=R_in
  do while(R.le.R_out)
    call GreenLip(R,R_,t,R_in,R_out,n,root,n_root,Sigma,Mdot)
    write(*,*)R,Sigma,Mdot
    R=R+dR
  end do
return
end subroutine TestGreenFun01

!=========================================================================================================
! The subroutine calculates the first n roots of the equation ...
! The roots are usen in a series which represents the Green function.
! root(n) - the array containing "n" roots of equation.
! l - parameter descibing evolution of viscosity in accretion disc with the radial coordinate.
! x_in and x_out - parameters determining the inner and outer edges of accretion disc.
! Assumptions: zero-stress at the inner radius, zero-mass-accretion-rate at the outer radius.
!=========================================================================================================
subroutine rootsLipunova(root,n,l,x_in,x_out)
implicit none
integer,intent(in)::n
real*8,intent(in)::l,x_in,x_out
real*8::root,root_down,root_up
dimension root(n),root_down(n,2),root_up(n,2)
real*8::k,dk,res1,res2,eps,k1,k2,res
integer::i

  dk=1.d-1      !==step: should be shousen somehow==!
  k=0.d0
  !root_down(1,1)=0.d0;  root_down(1,2)=0.d0
  res2=eq_Lip(k,l,x_in,x_out)
  i=1
  do while(i.le.n)
    res1=res2
    res2=eq_Lip(k+dk,l,x_in,x_out)
    !write(*,*)k,res1
    if((res1*res2).le.0.d0)then
      root_down(i,1)=k;  root_down(i,2)=res1
      root_up(i,1)=k+dk; root_up(i,2)=res2
      !write(*,*)i,root_down(i,2),root_up(i,2)
      i=i+1
    end if
    !write(*,*)k,eq_Lip(k,l,x_in,x_out)
    k=k+dk
  end do
  eps=1.e-5 !min(root_down(2,1)-root_down(1,1),root_down(n,1)-root_down(n-1,1))/1.d4
  !write(*,*)eps

  i=1
  do while(i.le.n)
    k1=root_down(i,1); k2=root_up(i,1)
    res1=root_down(i,2); res2=root_up(i,2)
    do while(abs(k2-k1).gt.eps)
      k=(k2+k1)/2.d0
      res=eq_Lip(k,l,x_in,x_out)
      if((res*res1).gt.0.d0)then
        res1=res; k1=k
      else
        res2=res; k2=k
      end if
    end do
    root(i)=(k1+k2)/2.d0
    !write(*,*)i,root(i),root(i)-root(max(i-1,1))
    !read(*,*)
    i=i+1
  end do

return
contains
  real*8 function eq_Lip(k,l,x_in,x_out)
  implicit none
  real*8,intent(in)::k,l,x_in,x_out
  real*8::funBessel,mo,mi
    mo=k*x_out
    mi=k*x_in
    !eq_Lip=l/x_out*((1.d0-k)*funBessel(l,k*x_out)*funBessel(-l,k*x_in)-(1.d0+k)*funBessel(-l,k*x_out)*funBessel(l,k*x_in))&
    !      +k**2*(funBessel(l-1.d0,k*x_out)*funBessel(-l,k*x_in)-funBessel(-l-1.d0,k*x_out)*funBessel(l,k*x_in))
    !eq_Lip=-2.d0*l/x_out*funBessel(-l,k*x_out)*funBessel(l,k*x_in)&
    !       +k*(funBessel(l-1.d0,k*x_out)*funBessel(-l,k*x_in)-funBessel(-l-1.d0,k*x_out)*funBessel(l,k*x_in))
    eq_Lip=funBessel(-l,mi)*(l/x_out*funBessel(l,mo)+k/2.d0*(funBessel(l-1.d0,mo)-funBessel(l+1.d0,mo)))&
          +funBessel(+l,mi)*(k/2.d0*(funBessel(-l+1.d0,mo)-funBessel(-l-1.d0,mo))-l/x_out*funBessel(-l,mo))
  return
  end function eq_Lip
end subroutine rootsLipunova

!================================================================================================
! The subroutine calculates the surface density and mass accretion rate according to solutions given
! by Lipunova.
! R - radial coordiante of interest; R_ - the radial coordinate of the initial perturbation
! R_in - inner radius, R_out - outher radius
! n - power describing kinematic viscosity
! k_i(num) - array with the roots of Lipunova's equation
! num - the number of roots which we use.
! tv_in - time-scale in units of viscous time at R=1
!!!!!! still numerical differentiation!!!!!
!================================================================================================
subroutine GreenLip(R,R_,tv_in,R_in,R_out,n,k_i,num,Sigma,Mdot)
implicit none
real*8,intent(in)::R,R_,R_in,R_out,tv_in,n
integer::num
real*8::t,res,res_,k,dR,l,x_in,x_out,resMdot,Sigma,Mdot
real*8::pi=3.141592653589793d0
real*8:: k_i
dimension k_i(num)
integer::i

  t=tv_in*R_out**(n-2.d0)

  dR=1.d-4    !==this value provides the most accurate resolution of the numerical scheme

  l=0.5d0/(2.d0-n)
  x_in=(R_in/R_out)**(1.d0-n/2.d0)
  x_out=(R_out/R_out)**(1.d0-n/2.d0)

  res=0.d0
  res_=0.d0
  i=1
  do while(i.le.num)
    res =res +fGreenLip(k_i(i),R,R_,R_in,R_out,t,n)
    res_=res_+fGreenLip(k_i(i),R+dR,R_,R_in,R_out,t,n)
    i=i+1
  end do
  !==getting the surface density==!
  res =res *R**(-n-0.25d0)*R_**(5.d0/4.d0)*R_out**(n-2.d0) *(2.d0-n)
  res_=res_*(R+dR)**(-n-0.25d0)*R_**(5.d0/4.d0)*R_out**(n-2.d0) *(2.d0-n)

  !==differentiation and getting dotM==!
  resMdot=(res_*(R+dR)**(n+0.5d0)-res*(R)**(n+0.5d0))/dR
  resMdot=resMdot*sqrt(R)*6.d0*pi

  Sigma=res
  Mdot=resMdot
return
contains

  real*8 function fGreenLip(k_i,R,R_,R_in,R_out,t,n)
  implicit none
  real*8::pi=3.141592653589793d0
  real*8,intent(in)::k_i,R,R_,R_in,R_out,t,n
  real*8::l,x,x_,x_in,x_out,y,y_,y_in
  real*8::res
    l=0.5d0/(2.d0-n)
    x =(R/R_out)**(1.d0-0.5d0*n)
    x_=(R_/R_out)**(1.d0-0.5d0*n)
    x_in=(R_in/R_out)**(1.d0-0.5d0*n)
    x_out=(R_out/R_out)**(1.d0-0.5d0*n)
    res=exp(-2.d0*(1.d0-n/2.d0)**2*k_i**2*t)
    fGreenLip=res*Vi(k_i,x_,x_in,l)*Vi(k_i,x,x_in,l)/(Vi(k_i,x_out,x_in,l))**2
  return
  end function fGreenLip

  !==function for GreenLip==!
  real*8 function Vi(k_i,x,x_in,l)
  implicit none
  real*8,intent(in)::k_i,x,x_in,l
  real*8::funBessel  !==functions==!
    Vi=funBessel(l,k_i*x)*funBessel(-l,k_i*x_in)-funBessel(-l,k_i*x)*funBessel(l,k_i*x_in)
  return
  end function Vi
end subroutine GreenLip

!==========================================================================================================================
! The function calculates the Green function for the mass accretion rate in the frequency domain.
! The calculations are based on semi-analytical manner.
! The radial dirivative in the definition of dotM is taken analytically.
! fv_in - frequency in units of viscous frequency at R=1.
!==========================================================================================================================
complex*16 function GreenLip_F2(R,R_,fv_in,R_in,R_out,n,k_i,num)
implicit none
real*8,intent(in)::R,R_,R_in,R_out,fv_in,n
integer::num
real*8::res_Re,res_Im,k,l,x_in,x_out,f
complex*16::c_make  !==function==!
complex*16::fGLip
real*8::pi=3.141592653589793d0
real*8:: k_i
dimension k_i(num)
integer::i

  !f=fv_in*(R_in/R_out)**(n-2.d0)   !==the frequency in units of viscous frequency at R_out, this one is used in further calculations==!
  f=fv_in*(1.d0/R_out)**(n-2.d0)

  l=0.5d0/(2.d0-n)
  x_in=(R_in/R_out)**(1.d0-n/2.d0)
  x_out=1.d0

  !==summation over the roots of equation==!
  GreenLip_F2=(0.d0,0.d0)
  i=1
  do while(i.le.num)
    fGLip=fGreenLip_C(k_i(i),R,R_,R_in,R_out,f,n)

    GreenLip_F2=GreenLip_F2+fGLip
    i=i+1
  end do

  !==construct complex Green function out of the Re and Im parts==!
  GreenLip_F2=GreenLip_F2*6*pi*R**0.5d0*R_**0.25d0*(2.d0-n)
  GreenLip_F2=GreenLip_F2/4.d0
return
contains

  complex*16 function fGreenLip_C(k_i,R,R_,R_in,R_out,f,n)
  implicit none
  real*8::pi=3.141592653589793d0
  real*8,intent(in)::k_i,R,R_,R_in,R_out,f,n
  real*8::l,x,x_,x_in,x_out
  complex*16::res,ii
  real*8::funBessel  !==functions==!
    ii=(0.d0,1.d0)
    l=0.5d0/(2.d0-n)
    x =(R/R_out)**(1.d0-0.5d0*n)
    x_=(R_/R_out)**(1.d0-0.5d0*n)
    x_in=(R_in/R_out)**(1.d0-0.5d0*n)
    x_out=1.d0 !(R_out/R_out)**(1.d0-0.5d0*n)
    res=1.d0/(4.d0*ii*pi*f+k_i**2*(n-2.d0)**2)

    fGreenLip_C=res*Vi(k_i,x_,x_in,l)/(Vi(k_i,x_out,x_in,l))**2 &
                *R**(-0.75d0)*0.25d0*(k_i*(2.-n)*x* &
                (funBessel(-l,k_i*x_in)*(funBessel(l-1.,k_i*x)-funBessel(l+1.,k_i*x))&
                -funBessel(l,k_i*x_in)*(funBessel(-l-1.,k_i*x)-funBessel(-l+1,k_i*x))) &
                +Vi(k_i,x,x_in,l))
  return
  end function fGreenLip_C

  real*8 function fGreenLip_Re(k_i,R,R_,R_in,R_out,f,n)
  implicit none
  real*8::pi=3.141592653589793d0
  real*8,intent(in)::k_i,R,R_,R_in,R_out,f,n
  real*8::l,x,x_,x_in,x_out
  real*8::res_Re
  complex*16::res,ii
  real*8::funBessel  !==functions==!
    ii=(0.d0,1.d0)
    l=0.5d0/(2.d0-n)
    x =(R/R_out)**(1.d0-0.5d0*n)
    x_=(R_/R_out)**(1.d0-0.5d0*n)
    x_in=(R_in/R_out)**(1.d0-0.5d0*n)
    x_out=(R_out/R_out)**(1.d0-0.5d0*n)
    res=1.d0/(4.d0*ii*pi*f+k_i**2*(n-2.d0)**2)
    res_Re=realpart(res)

    fGreenLip_Re=res_Re*Vi(k_i,x_,x_in,l)/(Vi(k_i,x_out,x_in,l))**2 &
                 *R**(-0.75d0)*0.25d0*(k_i*(2.-n)*x* &
                (funBessel(-l,k_i*x_in)*(funBessel(l-1.,k_i*x)-funBessel(l+1.,k_i*x))&
                 -funBessel(l,k_i*x_in)*(funBessel(-l-1.,k_i*x)-funBessel(-l+1,k_i*x))) &
                +Vi(k_i,x,x_in,l))

  return
  end function fGreenLip_Re
  !===========================================================================================

  real*8 function fGreenLip_Im(k_i,R,R_,R_in,R_out,f,n)
  implicit none
  real*8::pi=3.141592653589793d0
  real*8,intent(in)::k_i,R,R_,R_in,R_out,f,n
  real*8::l,x,x_,x_in,x_out
  real*8::res_Im
  complex*16::res,ii
  real*8::funBessel  !==functions==!
    ii=(0.d0,1.d0)
    l=0.5d0/(2.d0-n)
    x =(R/R_out)**(1.d0-0.5d0*n)
    x_=(R_/R_out)**(1.d0-0.5d0*n)
    x_in=(R_in/R_out)**(1.d0-0.5d0*n)
    x_out=(R_out/R_out)**(1.d0-0.5d0*n)
    res=1.d0/(4.d0*ii*pi*f+k_i**2*(n-2.d0)**2)
    res_Im=imagpart(res)

    fGreenLip_Im=res_Im*Vi(k_i,x_,x_in,l)/(Vi(k_i,x_out,x_in,l))**2 &
                  *R**(-0.75d0)*0.25d0*(k_i*(2.-n)*x* &
                  (funBessel(-l,k_i*x_in)*(funBessel(l-1.,k_i*x)-funBessel(l+1.,k_i*x))&
                  -funBessel(l,k_i*x_in)*(funBessel(-l-1.,k_i*x)-funBessel(-l+1,k_i*x))) &
                  +Vi(k_i,x,x_in,l))
  return
  end function fGreenLip_Im
  !========================================================================================

  !==function for GreenLip==!
  real*8 function Vi(k_i,x,x_in,l)
  implicit none
  real*8,intent(in)::k_i,x,x_in,l
  real*8::funBessel  !==functions==!
    Vi=funBessel(l,k_i*x)*funBessel(-l,k_i*x_in)-funBessel(-l,k_i*x)*funBessel(l,k_i*x_in)
  return
  end function Vi
end function GreenLip_F2
!================================================================================================

!==========================================================================================================================
! The function calculates the Green function for the mass accretion rate in the frequency domain.
! The calculations are based on semi-analytical manner.
! fv_in - frequency in units of viscous frequency at the inner disc radius.
! The derivative is calculated numerically here.
!==========================================================================================================================
complex*16 function GreenLip_F(R,R_,fv_in,R_in,R_out,n,k_i,num)
implicit none
real*8,intent(in)::R,R_,R_in,R_out,fv_in,n
integer::num
real*8::res_Re,res_Im,res_Re_,res_Im_,k,dR,l,x_in,x_out,f
complex*16::c_make
real*8::pi=3.141592653589793d0
real*8:: k_i
dimension k_i(num)
integer::i

  f=fv_in*(R_in/R_out)**(n-2.d0)   !==the frequency in units of viscous frequency at R_out, this one is used in further calculations==!

  dR=1.d-5   !0.05d0  !==this value provides the most accurate resolution of the numerical scheme

  l=0.5d0/(2.d0-n)
  x_in=(R_in/R_out)**(1.d0-n/2.d0)
  x_out=(R_out/R_out)**(1.d0-n/2.d0)
  !call rootsLipunova(k_i,num,l,x_in,x_out)

  res_Re=0.d0
  res_Im=0.d0
  res_Re_=0.d0
  res_Im_=0.d0
  i=1
  do while(i.le.num)
    res_Re=res_Re+fGreenLip_Re(k_i(i),R,R_,R_in,R_out,f,n)
    res_Im=res_Im+fGreenLip_Im(k_i(i),R,R_,R_in,R_out,f,n)

    res_Re_=res_Re_+fGreenLip_Re(k_i(i),R+dR,R_,R_in,R_out,f,n)
    res_Im_=res_Im_+fGreenLip_Im(k_i(i),R+dR,R_,R_in,R_out,f,n)

    i=i+1
  end do
  res_Re=res_Re *R**(-n-0.25d0)*R_**(5.d0/4.d0)*R_out**(n-2.d0) *(2.d0-n)
  res_Im=res_Im *R**(-n-0.25d0)*R_**(5.d0/4.d0)*R_out**(n-2.d0) *(2.d0-n)

  res_Re_=res_Re_ *(R+dR)**(-n-0.25d0)*R_**(5./4.)*R_out**(n-2.d0) *(2.d0-n)
  res_Im_=res_Im_ *(R+dR)**(-n-0.25d0)*R_**(5./4.)*R_out**(n-2.d0) *(2.d0-n)

  !==differentiation==!
  res_Re=(res_Re_*(R+dR)**(n+0.5d0)-res_Re*(R)**(n+0.5d0))/dR
  res_Im=(res_Im_*(R+dR)**(n+0.5d0)-res_Im*(R)**(n+0.5d0))/dR
  !write(*,*)"# ",res_Re,res_Im

  !==construct complex Green function out of the Re and Im parts==!
  GreenLip_F=(1.d0,0.d0)*res_Re+(0.d0,1.d0)*res_Im
  GreenLip_F=GreenLip_F*sqrt(R)*6*pi *(R_out/R_in)**(2.d0-n)
  GreenLip_F=GreenLip_F/4.d0/R_    !=sheck the reason for the 4==!
return
contains

  real*8 function fGreenLip_Re(k_i,R,R_,R_in,R_out,f,n)
  implicit none
  real*8::pi=3.141592653589793d0
  real*8,intent(in)::k_i,R,R_,R_in,R_out,f,n
  real*8::l,x,x_,x_in,x_out,y,y_,y_in
  real*8::res_mod,res_arg,res_Re,res_Im
  complex*16::res,ii
    ii=(0.d0,1.d0)
    l=0.5d0/(2.d0-n)
    x =(R/R_out)**(1.d0-0.5d0*n)
    x_=(R_/R_out)**(1.d0-0.5d0*n)
    x_in=(R_in/R_out)**(1.d0-0.5d0*n)
    x_out=(R_out/R_out)**(1.d0-0.5d0*n)
    res=1.d0/(4*ii*pi*f+k_i**2*(n-2.d0)**2)
    res_Re=realpart(res)
    fGreenLip_Re=res_Re*Vi(k_i,x_,x_in,l)*Vi(k_i,x,x_in,l)/(Vi(k_i,x_out,x_in,l))**2
    !fGreenLip_Re=res_Re !Vi(k_i,x_,x_in,l)*Vi(k_i,x,x_in,l)/(Vi(k_i,x_out,x_in,l))**2

    !fGreenLip_Re=res_Re*Vi(k_i,x_,x_in,l)/(Vi(k_i,x_out,x_in,l))**2 * ((n+1.d0)*Vi(k_i,x,x_in,l)+ k_i*x/4.d0/l)
  return
  end function fGreenLip_Re
  !===========================================================================================

  real*8 function fGreenLip_Im(k_i,R,R_,R_in,R_out,f,n)
  implicit none
  real*8::pi=3.141592653589793d0
  real*8,intent(in)::k_i,R,R_,R_in,R_out,f,n
  real*8::l,x,x_,x_in,x_out,y,y_,y_in
  real*8::res_mod,res_arg,res_Re,res_Im,res_2
  complex*16::res,ii

    ii=(0.d0,1.d0)
    l=0.5d0/(2.d0-n)
    x =(R/R_out)**(1.d0-0.5d0*n)
    x_=(R_/R_out)**(1.d0-0.5d0*n)
    x_in=(R_in/R_out)**(1.d0-0.5d0*n)
    x_out=(R_out/R_out)**(1.d0-0.5d0*n)
    res=1.d0/(4.d0*ii*pi*f+k_i**2*(n-2.d0)**2)
    res_Im=imagpart(res)
    fGreenLip_Im=res_Im*Vi(k_i,x_,x_in,l)*Vi(k_i,x,x_in,l)/(Vi(k_i,x_out,x_in,l))**2
    !fGreenLip_Im=res_Im!Vi(k_i,x_,x_in,l)*Vi(k_i,x,x_in,l)/(Vi(k_i,x_out,x_in,l))**2

    !fGreenLip_Im=res_Im*Vi(k_i,x_,x_in,l)/(Vi(k_i,x_out,x_in,l))**2 * ((n+1.d0)*Vi(k_i,x,x_in,l)+ k_i*x/4.d0/l)
  return
  end function fGreenLip_Im
  !========================================================================================

  !==function for GreenLip==!
  real*8 function Vi(k_i,x,x_in,l)
  implicit none
  real*8,intent(in)::k_i,x,x_in,l
  real*8::funBessel  !==functions==!
    Vi=funBessel(l,k_i*x)*funBessel(-l,k_i*x_in)-funBessel(-l,k_i*x)*funBessel(l,k_i*x_in)
  return
  end function Vi
end function GreenLip_F
!================================================================================================

!================================================================================================
! The subroutine controlls the mass in accretion disc described by Lipunovas Green functions.
! R_ - radial coordinate of initial distortion;
! t - time after the distortion at R_;
! R_in, R_out - inner and outer radii of accretion disc;
! n - describes the dependence of kinematic viscosity in accretion disc on radial coordinate;
! k_i(num) - array of a "num" roots of the transedental equation.
!================================================================================================
real*8 function GreenLipDicsMass(R_,t,R_in,R_out,n,k_i,num)
implicit none
real*8,intent(in)::R_,t,R_in,R_out,n,k_i
integer,intent(in)::num
dimension k_i(num)
real*8::R,dR,res,Sigma,Mdot
real*8::pi=3.141592653589793d0
integer::nn
  nn=2000     !==the number of points for integration over the radial coordinate==!
  dR=(R_out-R_in)/nn
  R=R_in
  res=0.d0
  do while(R.le.R_out)
    call GreenLip(R,R_,t,R_in,R_out,n,k_i,num,Sigma,Mdot)
    !Sigma=Sigma/R**(n+0.5d0)
    !write(*,*)R,Sigma,res
    !read(*,*)
    res=res+2*pi*R*dR*Sigma
    R=R+dR
  end do
  GreenLipDicsMass=res
return
end function GreenLipDicsMass


! This program gives a test driver for the DVODE test problem.
!
! Changing the value of max(alpha, beta) / min(alpha, beta) changes the
! stiffness of the problem.  A very stiff problem, such as reaction networks,
! really gives DVODE a nice workout.  Adjusting the atol and rtol parameters
! can give some insight as to what these values should be to give a reasonable
! result for some given initial conditions.  More information about this
! reaction network and the equations involved can be found in ../README.
!
! The function xbxa gives the analytic solution to the system given the
! initial condition xb(t=0) = 0 and of course the condition sum_i x_i = 1.
!
program testburn

  use burner_module
  use network
  use bl_types
  use bl_constants_module

  implicit none

  real(kind=dp_t) :: x_dvode(nspec), x_new(nspec), tol(2)
  real(kind=dp_t) :: analytic_soln, dvode_soln

  real(kind=dp_t) :: tstep, time

  integer :: i, j, k

  ! number of burn steps to take
  integer, parameter :: imax = 1000

  ! rate parameters
  real(kind=dp_t), parameter :: alpha = 8.0d9, &
                                 beta = 4.0d-6

  ! tolerance parameters
  real(kind=dp_t), parameter :: atol = 1.0d-15, &
                                rtol = 1.0d-12

  ! species information
  integer :: ia, ib

  if (.not. network_initialized) then
     call network_init

     ia = network_species_index("A")
     ib = network_species_index("B")

  endif

! initial conditions
  x_dvode(ia) = ONE
  x_dvode(ib) = ZERO

  rates(ia,ia) = -alpha
  rates(ib,ia) =  alpha
  rates(ib,ib) =  -beta
  rates(ia,ib) =   beta

  time = ZERO

  ! some value of timestep...
  ! this doesn't seem to affect the solution too much as DVODE will take
  ! a corrected timestep if this does not work
  tstep = 2.d-11

  tol(1) = atol
  tol(2) = rtol

  print *, ' alpha = ', alpha
  print *, '  beta = ', beta
  print *, ' tstep = ', tstep
  print *, '  atol = ', atol
  print *, '  rtol = ', rtol
  print *, ''
  print *, '  time           analytic               DVODE     ', &
           '        % difference'

! open a file for output
  open(unit=1,file='testburn.out',status='unknown',action='write')
  write(1,*)'# alpha = ', alpha
  write(1,*)'#  beta = ', beta
  write(1,*)'# tstep = ', tstep
  write(1,*)'#  atol = ', atol
  write(1,*)'#  rtol = ', rtol
  write(1,*)'# time           analytic               DVODE     ', &
           '        % difference'

  do i = 1, imax
     time = i * tstep

     call burner(x_dvode, tstep, tol, x_new)

     x_dvode(:) = x_new(:)

     dvode_soln = x_dvode(ib)/x_dvode(ia)

     analytic_soln = xbxa(time, alpha, beta)

     write(6,100) time, analytic_soln, dvode_soln,                          &
              (abs(analytic_soln - dvode_soln)/analytic_soln) * 1.d2
     ! dump out to a file
     write(1,100) time, analytic_soln, dvode_soln,                          &
              (abs(analytic_soln - dvode_soln)/analytic_soln) * 1.d2

  enddo

  close(1)

100 format (ES10.3, 3(1x, ES20.12))

contains

  function xbxa(t, a, b)

    real(kind=dp_t) :: t, a, b, xbxa

    xbxa = (1 - dexp(-(a + b)*t)) / ((b/a)  +  dexp(-(a + b)*t))

    return

  end function xbxa

end program testburn


program complex1
complex :: x
x = (3.0, 4.0)
end program


: CR 10 EMIT ;
: PUTS 48 + EMIT CR ;

-1 0= PUTS
 0 0= PUTS
 1 0= PUTS
CR
-1 0<> PUTS
 0 0<> PUTS
 1 0<> PUTS
CR
-1 0< PUTS
 0 0< PUTS
 1 0< PUTS
CR
-1 0> PUTS
 0 0> PUTS
 1 0> PUTS
CR
-1 0<= PUTS
 0 0<= PUTS
 1 0<= PUTS
CR
-1 0>= PUTS
 0 0>= PUTS
 1 0>= PUTS


! { dg-do run }
!
! PR 36322/36463
!
! Contributed by Janus Weil <janus@gcc.gnu.org>

module m

contains

  pure integer function mysize(a)
    integer,intent(in) :: a(:)
    mysize = size(a)
  end function

end module

program prog

use m
implicit none

abstract interface
  function abs_fun(x,sz)
    integer,intent(in) :: x(:)
    interface
      pure integer function sz(b)
        integer,intent(in) :: b(:)
      end function
    end interface
    integer :: abs_fun(sz(x))
  end function
end interface

procedure(abs_fun) :: p

integer :: k,j(3),i(3) = (/1,2,3/)

j = p(i,mysize)

do k=1,mysize(i)
  if (j(k) /= 2*i(k)) call abort()
end do

end

  function p(y,asz)
    implicit none
    integer,intent(in) :: y(:)
    interface
      pure integer function asz(c)
        integer,intent(in) :: c(:)
      end function
    end interface
    integer :: p(asz(y))
    integer l
    do l=1,asz(y)
      p(l) = y(l)*2
    end do
  end function


! Program to test array expressions in array constructors.
program nestcons
   implicit none
   integer, parameter :: w1(3)= (/ 5, 6, 7/)
   integer, dimension(6) :: w2

   w2 = (/ 1, 2, w1(3:1:-1), 3 /)
   if (any (w2 .ne. (/ 1, 2, 7, 6, 5, 3/))) call abort
end


SUBROUTINE qinit(meqn,mbc,mx,xlower,dx,q,maux,aux)
    IMPLICIT NONE

    INTEGER meqn,mbc,mx,maux
    DOUBLE PRECISION xlower,dx

    DOUBLE PRECISION q(meqn,1-mbc:mx+mbc)
    DOUBLE PRECISION aux(maux,1-mbc:mx+mbc)

    DOUBLE PRECISION  grav
    COMMON /common_swe/ grav

    DOUBLE PRECISION pi, pi2
    COMMON /compi/ pi, pi2

    double precision :: a,b,h0
    common /common_initheight/ a,b,h0

    DOUBLE PRECISION xc,hr, hl, ur
    INTEGER i

!!
    hl = h0 + a
    hr = h0
    ur = 0.d0

    do i = 1,mx
        xc = xlower + (i-0.5d0)*dx
        if (abs(xc) .lt. b) then
            q(1,i) = hl
        else
            q(1,i) = hr
        endif
        q(2,i) = 0
    end do

    return
end subroutine qinit


module ode_solvers
  use utils, only: fp,ip
  abstract interface
     subroutine ode_solver(x,y0,f,y,dx_in,tol_in)
       use utils, only: fp,ip
       use fclass
       implicit none
       real(fp), dimension(:),intent(in) :: x
       complex(fp), dimension(:),intent(in) :: y0
       complex(fp), dimension(:,:),intent(out) :: y
       real(fp),optional :: dx_in,tol_in
       class(fd) :: f
     end subroutine ode_solver
  end interface
contains
  subroutine test_solver(x,y0,f,y,dx)
    use utils, only: fp,ip
    use fclass
    implicit none
    real(fp),dimension(:),intent(in) :: x
    complex(fp), dimension(:),intent(in) :: y0
    complex(fp), dimension(:,:),intent(out) :: y
    class(fd) :: f
    real(fp),optional :: dx
    call f%value_at(x(1),y0,y(1,:))
  end subroutine test_solver

  subroutine euler(x,y0,f,y,dx_in,tol_in)
    use utils, only: fp,ip
    use hamiltonians
    use fclass
    implicit none
    real(fp), dimension(:),intent(in) :: x
    complex(fp), dimension(:),intent(in) :: y0
    complex(fp), dimension(:,:),intent(out) :: y
    class(fd) :: f
    real(fp),optional :: dx_in,tol_in
    real(fp) :: dx,xc,xn,dxc
    integer(ip) :: ii,n,jj,dim
    complex(fp),dimension(:), allocatable :: fn,yn
    logical :: write_next

    n = size(x)
    dim = size(y0)
    if(n < 2) then
       write(*,*) 'At least 2 query points must be defined.'
       stop
    end if

    if(size(y,2) .NE. n) then
       write(*,*) 'Size of output array is not equal to query points.'
       stop
    end if

    if(present(dx_in)) then
       dx = dx_in
       if(dx > (x(2) - x(1))/2.0_fp) then
          dx = x(2) - x(1)
       end if
    else
       dx=x(2) - x(1)
    endif
    allocate(fn(dim))
    allocate(yn(dim))

    y(:,1) = y0
    yn = y0
    ii = 2
    write_next = .false.

    !jj = 0

    do while(ii <= n)
       write_next = .false.
       xc = x(ii-1)
       xn = x(ii)
       do while(.true.)
          if(xc + dx + dx/1000_fp >= xn) then
             dxc = xn - xc
             write_next = .true.
          else
             dxc = dx
          end if
          !write(*,*) dx,dxc,xc,xn
          call f%value_at(xc,yn,fn)
          yn = yn + dxc*fn
          !jj = jj+1
          xc = xc + dxc
          if(write_next) then
             !write(*,*) jj
             y(:,ii) = yn
             exit
          end if
       end do
       ii = ii+1
    end do
    !write(*,*) ii-1,jj
    deallocate(fn,yn)
  end subroutine euler

  subroutine rk4(x,y0,f,y,dx_in,tol_in)
    use utils, only: fp,ip
    use fclass
    implicit none
    real(fp), dimension(:),intent(in) :: x
    complex(fp), dimension(:),intent(in) :: y0
    complex(fp), dimension(:,:),intent(out) :: y
    class(fd) :: f
    real(fp),optional :: dx_in,tol_in
    real(fp) :: dx,xc,xn,dxc
    integer(ip) :: ii,n,jj,dim
    complex(fp),dimension(:), allocatable :: fn,yn,k1,k2,k3,k4
    logical :: write_next

    n = size(x)
    dim = size(y0)
    if(n < 2) then
       write(*,*) 'At least 2 query points must be defined.'
       stop
    end if

    if(size(y,2) .NE. n) then
       write(*,*) 'Size of output array is not equal to query points.'
       stop
    end if

    if(present(dx_in)) then
       dx = dx_in
       if(dx > (x(2) - x(1))/2.0_fp) then
          dx = x(2) - x(1)
       end if
    else
       dx=x(2) - x(1)
    endif

    allocate(fn(dim))
    allocate(yn(dim))
    allocate(k1(dim),k2(dim),k3(dim),k4(dim))
    y(:,1) = y0
    yn = y0
    ii = 2

    do while(ii <= n)
       write_next = .false.
       xc = x(ii-1)
       xn = x(ii)
       do while(.true.)
          if(xc + dx + dx/1000_fp >= xn) then
             dxc = xn - xc
             write_next = .true.
          else
             dxc = dx
          end if

          call f%value_at(xc,yn,k1)
          call f%value_at(xc+dxc/2.0_fp,yn+dxc*k1/2.0_fp,k2)
          call f%value_at(xc+dxc/2.0_fp,yn+dxc*k2/2.0_fp,k3)
          call f%value_at(xc+dxc,yn+dxc*k3,k4)
          yn = yn + dxc*(k1+2*k2+2*k3+k4)/6.0_fp
          xc = xc + dxc

          if(write_next) then
             !write(*,*) jj
             y(:,ii) = yn
             exit
          end if
       end do
       ii = ii+1
    end do
    deallocate(k1,k2,k3,k4,fn,yn)
  end subroutine rk4

! THIS IS DEPRACATED
  subroutine rk45_interp_end(x,y0,f,y,dx_in,tol_in)
    use utils, only: fp,ip
    use fclass
    use linfuncs
    implicit none
    real(fp), dimension(:),intent(in) :: x
    complex(fp), dimension(:),intent(in) :: y0
    complex(fp), dimension(:,:),intent(out) :: y
    class(fd) :: f
    real(fp),optional :: dx_in,tol_in
    real(fp) :: dx,xc,xn,dxc,s,tol_min,tol_max,eps
    integer(ip) :: ii,n,jj,dim,dim_yvs
    integer(ip),parameter :: growth_factor = 5
    complex(fp),dimension(:), allocatable :: yn,k1,k2,k3,k4,k5,k6,zn
    complex(fp),dimension(:,:), allocatable :: yvs,tmp_yvs
    real(fp),dimension(:),allocatable :: xvs,tmp_xvs
    logical :: write_next
    real(fp),parameter :: a1 = 0.0_fp,a2 = 0.25_fp,a3 = 3.0_fp/8.0_fp,a4 = 12.0_fp/13.0_fp,&
         a5 = 1.0_fp,a6 = 0.5_fp
    real(fp),parameter :: b11 = 0.0_fp,b21 = 0.25_fp,b31 = 3.0_fp/32.0_fp,b32=9.0_fp/32.0_fp,&
         b41=1932.0_fp/2197.0_fp,b42=-7200.0_fp/2197.0_fp,b43=7296.0_fp/2197.0_fp,&
         b51=439.0_fp/216.0_fp,b52 = -8.0_fp,b53=3680.0_fp/513.0_fp,b54 = -845.0_fp/4104.0_fp,&
         b61 = -8.0_fp/27.0_fp,b62 = 2.0_fp,b63=-3544.0_fp/2565.0_fp,b64=1859.0_fp/4104.0_fp,&
         b65=11.0_fp/40.0_fp
    real(fp),parameter :: c1 = 25.0_fp/216.0_fp,c2 = 0.0_fp,c3=1408.0_fp/2565.0_fp,&
         c4=2197.0_fp/4101.0_fp,c5=-0.2_fp
    real(fp),parameter :: d1 = 16.0_fp/135.0_fp,d2=0.0_fp,d3=6656.0_fp/12825.0_fp,&
         d4=28561.0_fp/56430.0_fp,d5=-9.0_fp/50.0_fp,d6=2.0_fp/55.0_fp

    n = size(x)
    dim = size(y0)
    if(n < 2) then
       write(*,*) 'At least 2 query points must be defined.'
       stop
    end if

    if(size(y,2) .NE. n) then
       write(*,*) 'Size of output array is not equal to query points.'
       stop
    end if

    if(present(dx_in)) then
       dx = dx_in
    else
       dx = (x(2) - x(1))/101
    endif

    if(present(tol_in)) then
       tol_max = tol_in
    else
       tol_max = 0.001_fp
    end if
    tol_min = tol_max/1.5_fp
    allocate(yn(dim))
    allocate(k1(dim),k2(dim),k3(dim),k4(dim),k5(dim),k6(dim))
    dim_yvs = max(2*size(x),100)
    allocate(yvs(dim,dim_yvs))
    allocate(xvs(dim_yvs))
    y(:,1) = y0
    yvs(:,1) = y0
    yn = y0
    ii=2

    dx = 0.001_fp
    xc = x(1)

    do while(xc + dx/10000.0_fp < x(n))
       !write(*,*) 'Entering the loop!'
       !write(*,*) 'ii=',ii
       if(xc+dx>x(n)) then
          dx = x(n) - xc
       endif
       !write(*,*) 'x=',xc,', dx=',dx
       if(ii>dim_yvs) then !need to reallocate the data arrays
          allocate(tmp_xvs(dim_yvs))
          allocate(tmp_yvs(dim,dim_yvs))
          tmp_xvs = xvs
          tmp_yvs = yvs
          deallocate(yvs,xvs)
          allocate(yvs(dim,dim_yvs*growth_factor),xvs(dim_yvs*growth_factor))
          yvs(:,1:dim_yvs) = tmp_yvs
          xvs(1:dim_yvs) = tmp_xvs
          deallocate(tmp_yvs,tmp_xvs)
          dim_yvs = growth_factor*dim_yvs
       endif
       call f%value_at(xc+a1,yn,k1)
       call f%value_at(xc+a2*dx,yn + dx*(b21*k1),k2)
       call f%value_at(xc+a3*dx,yn + dx*(b31*k1+b32*k2),k3)
       call f%value_at(xc+a4*dx,yn + dx*(b41*k1+b42*k2+b43*k3),k4)
       call f%value_at(xc+a5*dx,yn + dx*(b51*k1+b52*k2+b53*k3+b54*k4),k5)
       call f%value_at(xc+a6*dx,yn + dx*(b61*k1+b62*k2+b64*k3+b64*k4+b65*k5),k6)
       yn = yn + dx*(c1*k1+c3*k3+c4*k4+c5*k5)
       zn = yn + dx*(d1*k1+d3*k3+d4*k4+d5*k5+d6*k6)
       eps = norm2(abs(zn-yn))
       !write(*,*) 'eps=',eps,', tol_max=',tol_max
       if(eps > tol_max) then ! reject!
          s = 0.84_fp*(tol_min/eps)**0.25_fp ! and reduce step size
          dx = s*dx
       else ! accept
          xc = xc + dx
          xvs(ii) = xc
          yvs(:,ii) = yn
          !yn = zn
          ii = ii+1
          if(eps < tol_min) then ! but increase step
             s = 0.84_fp*(tol_min/eps)**0.25_fp
             dx = s*dx
          endif
       endif
    end do
    y = interp1(xvs(1:(ii-1)),yvs(:,1:(ii-1)),x)
    deallocate(k1,k2,k3,k4,k5,k6,yn,zn,yvs,xvs)
    write(*,*) 'dx:',dx,', ii',ii
  end subroutine rk45_interp_end
!------------------------------------------
  subroutine rk45(x,y0,f,y,dx_in,tol_in)
    use utils, only: fp,ip
    use fclass
    use linfuncs
    implicit none
    real(fp), dimension(:),intent(in) :: x
    complex(fp), dimension(:),intent(in) :: y0
    complex(fp), dimension(:,:),intent(out) :: y
    class(fd) :: f
    real(fp),optional :: dx_in,tol_in
    real(fp) :: dx,xc,xn,dxc,s,tol_min,tol_max,eps,dx_min,dx_max
    integer(ip) :: ii,n,jj,dim,dim_yvs,jj_t,kk
    integer(ip),parameter :: growth_factor = 5
    complex(fp),dimension(:), allocatable :: yn,k1,k2,k3,k4,k5,k6,zn,yn_t
    complex(fp),dimension(:,:), allocatable :: yvs,yvs_t
    real(fp),dimension(:),allocatable :: xvs,xvs_t
    real(fp),parameter :: a1 = 0.0_fp,a2 = 0.25_fp,a3 = 3.0_fp/8.0_fp,a4 = 12.0_fp/13.0_fp,&
         a5 = 1.0_fp,a6 = 0.5_fp
    real(fp),parameter :: b11 = 0.0_fp,b21 = 0.25_fp,b31 = 3.0_fp/32.0_fp,b32=9.0_fp/32.0_fp,&
         b41=1932.0_fp/2197.0_fp,b42=-7200.0_fp/2197.0_fp,b43=7296.0_fp/2197.0_fp,&
         b51=439.0_fp/216.0_fp,b52 = -8.0_fp,b53=3680.0_fp/513.0_fp,b54 = -845.0_fp/4104.0_fp,&
         b61 = -8.0_fp/27.0_fp,b62 = 2.0_fp,b63=-3544.0_fp/2565.0_fp,b64=1859.0_fp/4104.0_fp,&
         b65=11.0_fp/40.0_fp
    real(fp),parameter :: c1 = 25.0_fp/216.0_fp,c2 = 0.0_fp,c3=1408.0_fp/2565.0_fp,&
         c4=2197.0_fp/4101.0_fp,c5=-0.2_fp
    real(fp),parameter :: d1 = 16.0_fp/135.0_fp,d2=0.0_fp,d3=6656.0_fp/12825.0_fp,&
         d4=28561.0_fp/56430.0_fp,d5=-9.0_fp/50.0_fp,d6=2.0_fp/55.0_fp

    n = size(x)
    dim = size(y0)
    if(n < 2) then
       write(*,*) 'At least 2 query points must be defined.'
       stop
    end if

    if(size(y,2) .NE. n) then
       write(*,*) 'Size of output array is not equal to query points.'
       stop
    end if

    if(present(dx_in)) then
       dx = dx_in
    else
       dx = (x(2) - x(1))/101.0_fp
    endif

    dx_max = dx

    if(present(tol_in)) then
       tol_max = tol_in
    else
       tol_max = 0.001_fp
    end if
    tol_min = tol_max/1.5_fp
    allocate(yn(dim),yn_t(dim),zn(dim))
    allocate(k1(dim),k2(dim),k3(dim),k4(dim),k5(dim),k6(dim))
    allocate(yvs(dim,4),yvs_t(dim,4))
    allocate(xvs(4),xvs_t(4))
    xvs = 0.0_fp
    xvs_t = 0.0_fp
    y(:,1) = y0
    yvs(:,1) = y0
    xvs(1) = x(1)
    yn = y0
    ii=2
    jj=2
    kk=2

    !dx = 0.001_fp
    xc = x(1)

    !do while(xc + dx/10000.0_fp < x(n))
    do while(xc + tiny(1.0_fp) < x(n))
       !write(*,*) 'Entering the loop!'
       !write(*,*) 'ii=',ii
       if(xc+dx>x(n)) then
          dx = x(n) - xc
       endif
       !write(*,*) 'x=',xc,', dx=',dx
       call f%value_at(xc+a1,yn,k1)
       call f%value_at(xc+a2*dx,yn + dx*(b21*k1),k2)
       call f%value_at(xc+a3*dx,yn + dx*(b31*k1+b32*k2),k3)
       call f%value_at(xc+a4*dx,yn + dx*(b41*k1+b42*k2+b43*k3),k4)
       call f%value_at(xc+a5*dx,yn + dx*(b51*k1+b52*k2+b53*k3+b54*k4),k5)
       call f%value_at(xc+a6*dx,yn + dx*(b61*k1+b62*k2+b64*k3+b64*k4+b65*k5),k6)
       yn_t = yn + dx*(c1*k1+c3*k3+c4*k4+c5*k5)
       zn = yn + dx*(d1*k1+d3*k3+d4*k4+d5*k5+d6*k6)
       eps = norm2(abs(zn-yn_t))
       !write(*,*) 'eps=',eps,', tol_max=',tol_max
       if(eps > tol_max) then ! reject!
          s = 0.84_fp*(tol_min/eps)**0.25_fp ! and reduce step size
          dx = s*dx
          !write(*,*) 'Too small step at ',xc,'. New dx is :',dx
       else ! accept
          yn = yn_t

          xc = xc + dx
          !write(*,*) 'Next x is :',xc
          xvs(ii) = xc
          yvs(:,ii) = yn

          jj_t = jj
          ! Loops as long as the current element in xvs is larger than the highest
          ! unprocessed element in x

          do while(jj < size(x) .and. x(jj) <= xvs(ii))
             jj = jj+1
          end do
          ! In order to also get the last element
          if(jj .eq. size(x) .and. x(jj) <= xvs(ii)) then
             jj = jj+1 ! Add one, because below jj-1 is used.
          end if

          if(kk>4) then ! xvs is a circular buffer. Only order if xvs is filled.
             xvs_t = cshift(xvs,ii)
             yvs_t = cshift(yvs,ii,2)
          else
             xvs_t = xvs
             yvs_t = yvs
          endif
          ! jj tells which elements of x we need to process
          if(jj .NE. jj_t) then
             !write(*,*) 'dx:',dx,', ii:',ii,', jj:',jj
             !write(*,*) 'xvs:',xvs
             !write(*,*) 'xvs_t:',xvs_t(1:min(4,kk))
             !write(*,*) 'x(jj):',x(jj)
             !write(*,*) 'x:',x(jj_t:jj-1)
             y(:,jj_t:jj-1) = interp1(xvs_t(1:min(4,kk)),yvs_t(:,1:min(4,kk)),x(jj_t:jj-1))
          end if

          !yn = zn
          ii = mod(ii,4)+1
          kk = kk+1
          if(eps < tol_min) then ! but increase step
             s = 0.84_fp*(tol_min/eps)**0.25_fp
             dx = s*dx
             dx = min(dx,(x(n)-x(1))/10.0_fp,dx_max) ! Limit the maximum step size. Otherwise risk infinity
             !write(*,*) 'Too big step at ',xc,'. New dx is :',dx
          endif
       endif
    end do
    !y = interp1(xvs(1:(ii-1)),yvs(:,1:(ii-1)),x)
    deallocate(k1,k2,k3,k4,k5,k6,yn,zn,yvs,xvs)
    !write(*,*) 'RK45 finished. dx:',dx,', nbr of iterations',kk
  end subroutine rk45
end module ode_solvers

! program test_ode_solvers
!   use utils, only: fp,ip
!   use fclass
!   use ode_solvers
!   use linfuncs
!   use hamiltonians
!   use operators
!   use signals
!   use envelopes
!   use random
!   implicit none
!   real(fp),allocatable,dimension(:) :: x,wq,xquery
!   complex(fp),allocatable,dimension(:) :: y0s,y0m
!   complex(fp),allocatable,dimension(:,:) :: ys,ym,yquery
!   complex(fp) :: H(2,2)
!   type(fdstd) :: ftd
!   type(fdsti) :: fti
!   type(fdmtd) :: fmtd

!   type(fdstd) :: ftd_driven
!   integer(ip) :: ii,NN,c1,c2,nql,ncl,jj
!   type(simple_hamiltonian) :: Hs
!   type(jch) :: Hjc
!   type(djch) :: Hdjc
!   integer(ip) :: test_dimensions(3)
!   type(operator_cont) :: op
!   procedure(ode_solver),pointer :: solver => null()
!   type(signal) :: test_signal
!   type(constant_envelope) :: cenv
!   type(lcg) :: lcg_t
!   real(fp),dimension(:),allocatable :: rnumber
!   integer(dip),dimension(:),allocatable :: inumber
!   integer(ip) :: nr
!   type(fdlmtd) :: flmtd

!   test_dimensions = [2,1,1]
!   NN = 1001
!   nql = 5
!   ncl = 1

!   solver => rk45
!   !call op%initialize(test_dimensions)

!   allocate(y0s(nql*ncl))
!   allocate(y0m((nql*ncl)**2))
!   y0s = (0.0_fp,0.0_fp)
!   y0s(2) = 1.0_fp
!   y0m = reshape(matmul(reshape(y0s,[size(y0s),1]),reshape(y0s,[1,size(y0s)])),[size(y0m)])
!   !write(*,*) real(y0)
!   !y0 = [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0]
!   !allocate(y0(NH))
!   allocate(x(NN))
!   allocate(ys(size(y0s),NN))
!   allocate(ym(size(y0m),NN))
!   allocate(wq(nql))
!   allocate(xquery(NN/3),yquery(size(y0s),NN/3))
!   wq = 0.0_fp
!   do ii=1,size(wq)
!      wq(ii) = ii**0.7
!   end do

!   call linspace(0.0_fp,1000.0_fp,NN,x)
!   call linspace(0.0_fp,0.1_fp,NN/3,xquery)
!   !  f = fd(H)

!   !call Hs%initialize_simple_H(2,0.0_fp,1.0_fp)
!   call Hdjc%initialize_djch(nql,ncl,wq,0.5_fp,1.0_fp,hbar_in = 1.0_fp)
!   call test_signal%initialize(Hdjc%op%cc(:,:,1),1.0_fp)
!   call cenv%initialize_constant_envelope((0.01_fp,0.0_fp))
!   call test_signal%add_envelope(cenv)
!   call Hdjc%add_signal(test_signal)

!   call Hjc%initialize_jch(nql,ncl,wq,0.5_fp,1.0_fp,hbar_in = 1.0_fp)
!   call fti%fdsti_initialize(Hjc%value_at(0.0_fp))
!   call ftd%fdstd_initialize(Hjc)
!   call ftd_driven%fdstd_initialize(Hdjc)
!   call fmtd%fdmtd_initialize(Hjc)

!   call flmtd%initialize_fdlmtd(Hdjc)
!   !call flmtd%add_lindblad_operator_fdlmtd(Hjc%op%aa(:,:,1),(0.01_fp,0.0_fp))
!   !call flmtd%add_lindblad_operator_fdlmtd(cmplx(get_diag_matrix(wq),kind=fp),(0.5_fp,0.0_fp))
!   call system_clock(c1)
!   !call euler(x,y0m,fmtd,ym,0.00001_fp)
!   !call euler(x,y0m,fmtd,ym,0.001_fp)
!   call solver(x,y0m,flmtd,ym,0.01_fp,0.01_fp)
!   call system_clock(c2)
!   write(*,*) 'DM execution took', (c2-c1), 'milliseconds'
!   call system_clock(c1)
!   !call euler(x,y0s,ftd,ys,0.00001_fp)
!   !call euler(x,y0s,ftd,ys,0.001_fp)
!   call rk4(x,y0s,ftd,ys,0.001_fp,0.01_fp)
!   call system_clock(c2)
!   write(*,*) 'SE execution with Hjc took', (c2-c1), 'milliseconds'
!   call system_clock(c1)
!   call rk4(x,y0s,ftd_driven,ys,0.001_fp,0.01_fp)
!   call system_clock(c2)
!   write(*,*) 'SE execution with Hdjc took', (c2-c1), 'milliseconds'

!   !call print_matrix(Hjc%value_at(0.0_fp),.true.)
!   !call print_matrix(Hjc%qcca,.true.)
!   !call print_matrix(Hjc%qacc,.true.)
!   !write(*,*) real(CONJG(y(1,:))*y(1,:))

!   yquery = interp1(x,ys,xquery)

!   open(unit = 1, file = 'test_data_s.dat')
!   open(unit = 2, file = 'test_data_m.dat')
!   open(unit = 3, file = 'test_data_q.dat')
!   do ii=1,size(x)
!      !write(1,*) x(ii),real(CONJG(y(:,ii))*y(:,ii))
!      write(1,*) x(ii),real(conjg(ys(:,ii))*ys(:,ii))
!      !write(2,*) x(ii),real(ym(:,ii))
!      write(2,"(f8.3)",advance='no') x(ii)
!      do jj=1,nql*ncl
!         write(2,"(f8.3)",advance='no') ,real(ym(nql*ncl*(jj-1) + jj,ii))
!      end do
!      write(2,*) ''
!   end do
!   do ii=1,size(xquery)
!      write(3,*) xquery(ii),real(conjg(yquery(:,ii))*yquery(:,ii))
!   end do
!   close(1)
!   close(2)
!   close(3)

!   !write(*,*) Hdjc%value_at(1.0_fp)
!   call lcg_t%init(generate_random_seed())
!   !rnumber = lcg_t%uniform(1)
!   !write(*,*) rnumber
!   !nr = 20
!   !allocate(inumber(nr),rnumber(nr))
!   !inumber = lcg_t%uniform_int(nr)
!   !rnumber = lcg_t%norm(nr)
!   !write(*,*) rnumber

! end program test_ode_solvers


      double complex function trI2(p1,m1,m2,mu2,ep)
c--- this is a switchyard routine: depending on value of
c--- integer variable, this routine either:
c---  TRscalarselect = 1    calls QCDLoop for scalar integral
c---  TRscalarselect = 2    calls OneLOop for scalar integral
c---  TRscalarselect = 3    calls both routines and compares results
c      use avh_olo
      implicit none
      include 'TRscalarselect.f'
      double precision p1,m1,m2,mu2
      double complex qlI2,resQCDLoop,resOneLOop,result(0:2)
      integer ep

      TRscalarselect=1

c--- call to QCDLoop if necessary
      if ((TRscalarselect .eq. 1) .or.(TRscalarselect .eq. 3)) then
        resQCDLoop=qlI2(p1,m1,m2,mu2,ep)
      endif

      if (TRscalarselect .eq. 1) then
        trI2=resQCDLoop
        return
      endif

      call olo_b0(result,p1,m1,m2,dsqrt(mu2))
      resOneLOop=result(abs(ep))
      trI2=resOneLOop

      if (TRscalarselect .eq. 3) then
        if ((cdabs(resOneLOop) .gt. 1d-12) .and.
     &      (abs(resQCDLoop/resOneLOop-1d0) .gt. 1d-12)) then
          write(6,*) 'trI2: ',p1,m1,m2,mu2,ep
          write(6,*) 'QCDLoop:',resQCDLoop
          write(6,*) 'OneLOop:',resOneLOop
          write(6,*) '->ratio:',resQCDLoop/resOneLOop
        endif
      endif

      return
      end


      subroutine zblas()
      d = dcabs1(z)
      call drotg(da,db,c,s)
      d = dzasum(n,zx,incx)
      d = dznrm2( n, zx, incx)
      call  zdrot (n,zx,incx,zy,incy,c,s)
      i = izamax(n,zx,incx)
      call zaxpy(n,za,zx,incx,zy,incy)
      call  zcopy(n,zx,incx,zy,incy)
      z = zdotc(n,zx,incx,zy,incy)
      z = zdotu(n,zx,incx,zy,incy)
      call  zdscal(n,da,zx,incx)
      d = zmach(job)
      call zrotg(ca,cb,c,s)
      call  zscal(n,za,zx,incx)
      call  zswap (n,zx,incx,zy,incy)
      stop
      end


!
!	Find estimated reliabilities of eap's of transformed latent vectors.
!	Input:
!	covartheta is the covariance matrix of the latent vector.
!	coveap is the covariance matrix of the eaps.
!	lintran is the transformation for the latent vector.
!	meancovtheta is the average conditional covariance of the latent vector given the observations.
!	meaneap is the average eap.

!	covarthetaskill is the covariance matrix of the transformed latent vector.
!	coveapskill is the covariance matrix of the eaps for the transformed latent vector.
!	meancovthetaskill is the average conditional covariance of the transformed latent vector
!		given the observations.
!	meaneapskill is the average eap for the transformed latent vector.
!	releapskill is the reliability of each
!		element of the transformed latent vector.
subroutine relthetaskill(covartheta,coveap,lintran,meancovtheta,meaneap,&
	covarthetaskill,coveapskill,meancovthetaskill,meaneapskill,releapskill)
implicit none
real(kind=8),intent(in)::covartheta(:,:),coveap(:,:),&
	lintran(:,:),meancovtheta(:,:),meaneap(:)

real(kind=8),intent(out)::covarthetaskill(:,:),coveapskill(:,:),&
	meancovthetaskill(:,:),meaneapskill(:),releapskill(:)
!	row counter.
integer::row
meaneapskill=matmul(lintran,meaneap)
coveapskill=matmul(lintran,matmul(coveap,transpose(lintran)))
meancovthetaskill=matmul(lintran,matmul(meancovtheta,transpose(lintran)))
covarthetaskill=coveapskill+meancovthetaskill
releapskill=0.0_8
do row=1,size(meaneapskill)
	if(covarthetaskill(row,row)>0.0_8)releapskill(row)=coveapskill(row,row)/covarthetaskill(row,row)
end do

end subroutine relthetaskill


  subroutine calc_Re(Q,Np,rho_a, &
             dtype,dmin,dmax,apm,bpm,rho_c,p1,p2,p3, &
             Re)
  use math_lib
  implicit none

! Purpose:
!   Calculates Effective Radius (1/2 distribution 3rd moment / 2nd moment).
!
!   For some distribution types, the total number concentration (per kg), Np
!   may be optionally specified.   Should be set to zero, otherwise.
!
!   Roj Marchand July 2010

! Inputs:
!
!   [Q]        hydrometeor mixing ratio (g/kg)  ! not needed for some distribution types
!   [Np]       Optional Total number concentration (per kg).  0 = use defaults (p1, p2, p3)
!
!   [rho_a]    ambient air density (kg m^-3)
!
!   Distribution parameters as per quickbeam documentation.
!   [dtype]    distribution type
!   [dmin]     minimum size cutoff (um)
!   [dmax]     maximum size cutoff (um)
!   [apm]      a parameter for mass (kg m^[-bpm])
!   [bmp]      b params for mass
!   [p1],[p2],[p3]  distribution parameters
!
!
! Outputs:
!   [Re]       Effective radius, 1/2 the 3rd moment/2nd moment (um)
!
! Created:
!   July 2010  Roj Marchand
!

! ----- INPUTS -----

  real*8, intent(in) :: Q,Np,rho_a

  integer, intent(in):: dtype
  real*8, intent(in) :: dmin,dmax,rho_c,p1,p2,p3

  real*8, intent(inout) :: apm,bpm

! ----- OUTPUTS -----

  real*8, intent(out) :: Re

! ----- INTERNAL -----

  integer :: local_dtype
  real*8  :: local_p3,local_Np

  real*8 :: pi, &
  N0,D0,vu,dm,ld, &         ! gamma, exponential variables
  rg,log_sigma_g

  real*8 :: tmp1,tmp2

  pi = acos(-1.0)

  ! // if density is constant, set equivalent values for apm and bpm
  if ((rho_c > 0) .and. (apm < 0)) then
    apm = (pi/6)*rho_c
    bpm = 3.
  endif

  ! Exponential is same as modified gamma with vu =1
  ! if Np is specified then we will just treat as modified gamma
  if(dtype.eq.2 .and. Np>0) then
    local_dtype=1;
    local_p3=1;
  else
    local_dtype=dtype;
    local_p3=p3;
  endif

  select case(local_dtype)

! ---------------------------------------------------------!
! // modified gamma                                        !
! ---------------------------------------------------------!
! :: Np = total number concentration (1/kg) = Nt / rho_a
! :: D0 = characteristic diameter (um)
! :: dm = mean diameter (um) - first moment over zeroth moment
! :: vu = distribution width parameter

  case(1)

    if( abs(local_p3+2) < 1E-8) then

    if(Np>1E-30) then
        ! Morrison scheme with Martin 1994 shape parameter (NOTE: vu = pc +1)
        ! fixed Roj. Dec. 2010 -- after comment by S. Mcfarlane
        vu = (1/(0.2714 + 0.00057145*Np*rho_a*1E-6))**2 ! units of Nt = Np*rhoa = #/cm^3
    else
        print *, 'Error: Must specify a value for Np in each volume', &
             ' with Morrison/Martin Scheme.'
            stop
    endif

    elseif (abs(local_p3+1) > 1E-8) then

      ! vu is fixed in hp structure
      vu = local_p3

    else

      ! vu isn't specified

      print *, 'Error: Must specify a value for vu for Modified Gamma distribution'
      stop

    endif

    if( Np.eq.0 .and. p2+1 > 1E-8) then     ! use default value for MEAN diameter as first default

        dm = p2             ! by definition, should have units of microns
    D0 = gamma(vu)/gamma(vu+1)*dm

    else   ! use value of Np

        if(Np.eq.0) then

            if( abs(p1+1) > 1E-8 ) then  !   use default number concentration

                local_Np = p1 ! total number concentration / pa --- units kg^-1
            else
            print *, 'Error: Must specify Np or default value ', &
                 '(p1=Dm [um] or p2=Np [1/kg]) for ', &
                 'Modified Gamma distribution'
                stop
            endif
        else
            local_Np=Np;
    endif

    D0 = 1E6 * ( Q*1E-3*gamma(vu)/(apm*local_Np*gamma(vu+bpm)) )**(1/bpm)  ! units = microns

    endif

    Re = 0.5*D0*gamma(vu+3)/gamma(vu+2)

! ---------------------------------------------------------!
! // exponential                                           !
! ---------------------------------------------------------!
! :: N0 = intercept parameter (m^-4)
! :: ld = slope parameter (um)

  case(2)

    ! Np not specified (see if statement above)

    if((abs(p1+1) > 1E-8) ) then   ! N0 has been specified, determine ld

        N0 = p1
    tmp1 = 1./(1.+bpm)
    ld = ((apm*gamma(1.+bpm)*N0)/(rho_a*Q*1E-3))**tmp1
    ld = ld/1E6                     ! set units to microns^-1

    elseif (abs(p2+1) > 1E-8) then  ! lambda=ld has been specified as default

        ld = p2     ! should have units of microns^-1

    else

    print *, 'Error: Must specify Np or default value ', &
         '(p1=No or p2=lambda) for Exponential distribution'
        stop

    endif

    Re = 1.5/ld ;

! ---------------------------------------------------------!
! // power law                                             !
! ---------------------------------------------------------!
! :: ahp = Ar parameter (m^-4 mm^-bhp)
! :: bhp = br parameter
! :: dmin_mm = lower bound (mm)
! :: dmax_mm = upper bound (mm)

  case(3)

    Re=0;  ! Not supporting LUT approach for power-law ...

    if(Np>0) then

        print *, 'Variable Np not supported for ', &
         'Power Law distribution'
        stop
    endif
! ---------------------------------------------------------!
! // monodisperse                                          !
! ---------------------------------------------------------!
! :: D0 = particle diameter (um) == Re

  case(4)

        Re = p1

        if(Np>0) then
        print *, 'Variable Np not supported for ', &
         'Monodispersed distribution'
        stop
    endif

! ---------------------------------------------------------!
! // lognormal                                             !
! ---------------------------------------------------------!
! :: N0 = total number concentration (m^-3)
! :: np = fixed number concentration (kg^-1)
! :: rg = mean radius (um)
! :: log_sigma_g = ln(geometric standard deviation)

  case(5)

        if( abs(local_p3+1) > 1E-8 ) then

            !set natural log width
            log_sigma_g = local_p3
        else
            print *, 'Error: Must specify a value for sigma_g ', &
             'when using a Log-Normal distribution'
            stop
        endif

    ! get rg ...
    if( Np.eq.0 .and. (abs(p2+1) > 1E-8) ) then ! use default value of rg

            rg = p2

        else
            if(Np>0) then

                local_Np=Np;

            elseif(abs(p2+1) < 1E-8) then

                local_Np=p1
            else
                print *, 'Error: Must specify Np or default value ', &
                 '(p2=Rg or p1=Np) for Log-Normal distribution'
            endif

            log_sigma_g = p3
            tmp1 = (Q*1E-3)/(2.**bpm*apm*local_Np)
            tmp2 = exp(0.5*bpm**2.*(log_sigma_g))**2.
            rg = ((tmp1/tmp2)**(1/bpm))*1E6
        endif

        Re = rg*exp(+2.5*(log_sigma_g**2))

  end select

  end subroutine calc_Re


!-----------------------------------------------------------------------
!     Subroutine:    vmec2xgc_pest2vmec
!     Authors:       S. Lazerson (lazerson@pppl.gov)
!     Date:          01/17/2017
!     Description:   This subroutine returns the VMEC poloidal angle
!                    given a PEST poloidal angle.  We use Fourier
!                    transforms as spline quantities (PSPLINE) was
!                    found to be insufficient.
!-----------------------------------------------------------------------
      SUBROUTINE vmec2xgc_pest2vmec(s,ustar,v,u)
!-----------------------------------------------------------------------
!     Libraries
!-----------------------------------------------------------------------
      USE stel_kinds, ONLY: rprec
      USE read_wout_mod
!-----------------------------------------------------------------------
!     Local Variables
!-----------------------------------------------------------------------
      IMPLICIT NONE
      REAL(rprec), INTENT(in) :: s, ustar, v
      REAL(rprec), INTENT(out) :: u
      INTEGER     :: mn,k1,k2,n1
      REAL(rprec) :: frac, ds, dth, lam, dlam, sinu, cosu
      REAL(rprec), ALLOCATABLE :: cnp(:),snp(:),fmns(:)
      DOUBLE PRECISION, PARAMETER      :: one = 1.0D+00
      DOUBLE PRECISION, PARAMETER      :: search_tol = 1.0D-12
      DOUBLE PRECISION, PARAMETER      :: pi2 = 6.283185482025146D+00
!-----------------------------------------------------------------------
!     Begin Subroutine
!-----------------------------------------------------------------------
      ALLOCATE(cnp(mnmax),snp(mnmax),fmns(mnmax))
      FORALL(mn = 1:mnmax) cnp(mn) = cos(xn(mn)*v/nfp)
      FORALL(mn = 1:mnmax) snp(mn) = sin(xn(mn)*v/nfp)
      ! Determine s and interpolate (linear)
      ds = one/REAL(ns)
      k1 = FLOOR(s*ns)
      k2 = CEILING(s*ns)
      frac = (s - REAL(k1)/REAL(ns))*ns
      FORALL(mn = 1:mnmax) fmns(mn) = (1-frac)*lmns(mn,k1)+frac*lmns(mn,k2)
      dth = one
      n1 = 0
      u = ustar
      DO WHILE(ABS(dth) >= search_tol .and. n1 < 5000)
         lam = 0
         dlam = 0
         DO mn = 1, mnmax
            cosu = fmns(mn)*cos(xm(mn)*u)
            sinu = fmns(mn)*sin(xm(mn)*u)
            lam = lam + sinu*cnp(mn)-cosu*snp(mn)
            dlam = dlam + xm(mn)*(cosu*cnp(mn)+sinu*snp(mn))
         END DO
         dth = -(u + lam - ustar)/(one+dlam)
         n1 = n1 + 1
         u = u + 0.5*dth
      END DO
      DEALLOCATE(cnp,snp,fmns)
      RETURN
!-----------------------------------------------------------------------
!     End Subroutine
!-----------------------------------------------------------------------
      END SUBROUTINE vmec2xgc_pest2vmec


!Joshua Dorrington 22/03/18 - University of Oxford
!This is the main executable program.

!This model solves a 6d spectral truncation of a baratropic beta plane model as
! first presented in [Charney & DeVore 1979]

!all model parameters are in params
!formulas for all spectral coefficients are in coeffs
!random number generation is in utils
!the model equations and integrator are in baratropic6d

program barotropic_model
	use, intrinsic :: iso_fortran_env
	use params
	use coeffs, only: get_coeffs, build_lin_op
	use utils, only: time_seed
	use barotropic6d, only: run_model
	implicit none

	!Initialise data structures
	real(dp), dimension(sample_num,dims) :: state_vector
	real(dp), dimension(coeff_num) :: coeff
	real(dp), dimension(dims,dims) :: lin_op
	integer :: inner_loop_size

	inner_loop_size=step_num/sample_num

	!Seed random numbers
	call time_seed()

	!Generate coefficients and the linear time evolution operator
	call get_coeffs(b,beta,g,coeff)
	call build_lin_op(lin_op,coeff)

	!Run the simulation
	call run_model(init_con,step_num,sample_num,state_vector,coeff,lin_op,inner_loop_size)

	!Write data to file
	OPEN( 10, FILE=save_file, access="stream")
	WRITE(10) state_vector
end program


*> \brief \b SQLT01
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE SQLT01( M, N, A, AF, Q, L, LDA, TAU, WORK, LWORK,
*                          RWORK, RESULT )
*
*       .. Scalar Arguments ..
*       INTEGER            LDA, LWORK, M, N
*       ..
*       .. Array Arguments ..
*       REAL               A( LDA, * ), AF( LDA, * ), L( LDA, * ),
*      $                   Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
*      $                   WORK( LWORK )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SQLT01 tests SGEQLF, which computes the QL factorization of an m-by-n
*> matrix A, and partially tests SORGQL which forms the m-by-m
*> orthogonal matrix Q.
*>
*> SQLT01 compares L with Q'*A, and checks that Q is orthogonal.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix A.  M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is REAL array, dimension (LDA,N)
*>          The m-by-n matrix A.
*> \endverbatim
*>
*> \param[out] AF
*> \verbatim
*>          AF is REAL array, dimension (LDA,N)
*>          Details of the QL factorization of A, as returned by SGEQLF.
*>          See SGEQLF for further details.
*> \endverbatim
*>
*> \param[out] Q
*> \verbatim
*>          Q is REAL array, dimension (LDA,M)
*>          The m-by-m orthogonal matrix Q.
*> \endverbatim
*>
*> \param[out] L
*> \verbatim
*>          L is REAL array, dimension (LDA,max(M,N))
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the arrays A, AF, Q and R.
*>          LDA >= max(M,N).
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*>          TAU is REAL array, dimension (min(M,N))
*>          The scalar factors of the elementary reflectors, as returned
*>          by SGEQLF.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is REAL array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The dimension of the array WORK.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*>          RWORK is REAL array, dimension (M)
*> \endverbatim
*>
*> \param[out] RESULT
*> \verbatim
*>          RESULT is REAL array, dimension (2)
*>          The test ratios:
*>          RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS )
*>          RESULT(2) = norm( I - Q'*Q ) / ( M * EPS )
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup single_lin
*
*  =====================================================================
      SUBROUTINE SQLT01( M, N, A, AF, Q, L, LDA, TAU, WORK, LWORK,
     $                   RWORK, RESULT )
*
*  -- LAPACK test routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            LDA, LWORK, M, N
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * ), AF( LDA, * ), L( LDA, * ),
     $                   Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
     $                   WORK( LWORK )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
      REAL               ROGUE
      PARAMETER          ( ROGUE = -1.0E+10 )
*     ..
*     .. Local Scalars ..
      INTEGER            INFO, MINMN
      REAL               ANORM, EPS, RESID
*     ..
*     .. External Functions ..
      REAL               SLAMCH, SLANGE, SLANSY
      EXTERNAL           SLAMCH, SLANGE, SLANSY
*     ..
*     .. External Subroutines ..
      EXTERNAL           SGEMM, SGEQLF, SLACPY, SLASET, SORGQL, SSYRK
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, REAL
*     ..
*     .. Scalars in Common ..
      CHARACTER*32       SRNAMT
*     ..
*     .. Common blocks ..
      COMMON             / SRNAMC / SRNAMT
*     ..
*     .. Executable Statements ..
*
      MINMN = MIN( M, N )
      EPS = SLAMCH( 'Epsilon' )
*
*     Copy the matrix A to the array AF.
*
      CALL SLACPY( 'Full', M, N, A, LDA, AF, LDA )
*
*     Factorize the matrix A in the array AF.
*
      SRNAMT = 'SGEQLF'
      CALL SGEQLF( M, N, AF, LDA, TAU, WORK, LWORK, INFO )
*
*     Copy details of Q
*
      CALL SLASET( 'Full', M, M, ROGUE, ROGUE, Q, LDA )
      IF( M.GE.N ) THEN
         IF( N.LT.M .AND. N.GT.0 )
     $      CALL SLACPY( 'Full', M-N, N, AF, LDA, Q( 1, M-N+1 ), LDA )
         IF( N.GT.1 )
     $      CALL SLACPY( 'Upper', N-1, N-1, AF( M-N+1, 2 ), LDA,
     $                   Q( M-N+1, M-N+2 ), LDA )
      ELSE
         IF( M.GT.1 )
     $      CALL SLACPY( 'Upper', M-1, M-1, AF( 1, N-M+2 ), LDA,
     $                   Q( 1, 2 ), LDA )
      END IF
*
*     Generate the m-by-m matrix Q
*
      SRNAMT = 'SORGQL'
      CALL SORGQL( M, M, MINMN, Q, LDA, TAU, WORK, LWORK, INFO )
*
*     Copy L
*
      CALL SLASET( 'Full', M, N, ZERO, ZERO, L, LDA )
      IF( M.GE.N ) THEN
         IF( N.GT.0 )
     $      CALL SLACPY( 'Lower', N, N, AF( M-N+1, 1 ), LDA,
     $                   L( M-N+1, 1 ), LDA )
      ELSE
         IF( N.GT.M .AND. M.GT.0 )
     $      CALL SLACPY( 'Full', M, N-M, AF, LDA, L, LDA )
         IF( M.GT.0 )
     $      CALL SLACPY( 'Lower', M, M, AF( 1, N-M+1 ), LDA,
     $                   L( 1, N-M+1 ), LDA )
      END IF
*
*     Compute L - Q'*A
*
      CALL SGEMM( 'Transpose', 'No transpose', M, N, M, -ONE, Q, LDA, A,
     $            LDA, ONE, L, LDA )
*
*     Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) .
*
      ANORM = SLANGE( '1', M, N, A, LDA, RWORK )
      RESID = SLANGE( '1', M, N, L, LDA, RWORK )
      IF( ANORM.GT.ZERO ) THEN
         RESULT( 1 ) = ( ( RESID / REAL( MAX( 1, M ) ) ) / ANORM ) / EPS
      ELSE
         RESULT( 1 ) = ZERO
      END IF
*
*     Compute I - Q'*Q
*
      CALL SLASET( 'Full', M, M, ZERO, ONE, L, LDA )
      CALL SSYRK( 'Upper', 'Transpose', M, M, -ONE, Q, LDA, ONE, L,
     $            LDA )
*
*     Compute norm( I - Q'*Q ) / ( M * EPS ) .
*
      RESID = SLANSY( '1', 'Upper', M, L, LDA, RWORK )
*
      RESULT( 2 ) = ( RESID / REAL( MAX( 1, M ) ) ) / EPS
*
      RETURN
*
*     End of SQLT01
*
      END


!***********************************************************************
!                                                                      *
      REAL(KIND(0.0D0)) FUNCTION SHIELD (J)
!                                                                      *
!   This  routine estimates the screening (or shielding) for orbital   *
!   J according to the relativistic hydrogenic energy formula.         *
!                                                                      *
!   Written by Yu Zou, at Vanderbilt University: 02 Mar 2000           *
!                                                                      *
!   Formula:                                                           *
!    epsilon = E(n,k)/Z^2_{eff}                                        *
!    beta = alpha Z_{eff}                                              *
!    epsilon = 1/beta^{2} [(1+beta^2/nu^2)^{-1/2} - 1]                 *
!    nu = n + (k^2 - beta^2)^{1/2} - |k|                               *
!   where E(n,k) is the orbital energy for the specific principal      *
!   quantum n and k quantum number, alpha is the fine structure        *
!   constant.                                                          *
!   Note that SHIELD is set to -C if Zeff is out of range. This will   *
!   ensure that the self-energy for such orbital is zero.              *
!   Reference: M J Seaton, Rep. Prog. Phys., Vol.46, P167,1983         *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:04:58   1/ 3/07
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE def_C
      USE orb_C
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: J
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      REAL(DOUBLE) :: A, AA, BB, CC, T, BETA
!-----------------------------------------------
!
!
! a=[(1+\alpha^2 E)^{-2} - 1]^{-1/2}
! note E(J) = -E(n,k)
      A = 1 - E(J)/(C*C)
      A = 1/(A*A) - 1
      IF (A < 0.0) THEN
         SHIELD = -C
         RETURN
      ENDIF
      A = 1/SQRT(A)
!
      AA = 1 + A*A
      BB = A*DBLE(NP(J)-IABS(NAK(J)))
      CC = DBLE((NP(J)-IABS(NAK(J)))**2-NAK(J)**2)
      T = BB*BB - AA*CC
      IF (T < 0.0) THEN
         SHIELD = -C
         RETURN
      ENDIF
      BETA = BB + SQRT(T)
      BETA = BETA/AA
      SHIELD = Z - BETA*C
!     print *, j, '  Initial Screen Factor = ',shield
      RETURN
      END FUNCTION SHIELD


!	Find individual residuals for weighted sums.
!	catobsrange provides ranges of underlying item categories that correspond to
!   observed item categories.
!	Responses are in dat.
!	numcat provides ranges for underlying observations.
!	numcatobs provides ranges for observations.

!	beta is the parameter vector.
!	lintran is the linear transformation for the latent vector.
!	postdensity contains posterior weights.
!	theta contains posterior quadrature points.
!	wtsum is a matrix used to compute linear combinations of the observations.

!   covreswt is the estimated covariance matrix of reswt.
!   fitwt is the estimated mean of the weighted sum.
!   obswt is the observed weighted sum.
!   reswt is the raw individual residual for the weighted sum.
!   sdreswt is the estimated standard error of the elements of reswt.
!   zreswt is the ratio of elements of reswt and sdreswt.

subroutine reswtsum(catobsrange,dat,numcat,numcatobs,beta,lintran,postdensity,theta,wtsum,&
    covreswt,fitwt,obswt,reswt,sdreswt,zreswt)
implicit none
interface
!	condprobvec is used to compute observed item conditional probabilities of underlying item categories given
!	observed item categories.
!	catobsrange provides ranges of underlying item categories that correspond to observed item categories.
!	numcatobs provides the number of observed categories per item.
!	resp is the item response.
!	mask indicates which items were presented.
!	probcat is the vector of underlying category probabilities.
!	probcatobs is the vector of observed category probabilities.
    function condprobvec(catobsrange,numcatobs,resp,mask,probcat,probcatobs)
        implicit none
        integer,intent(in)::catobsrange(:,:),numcatobs(:),resp(:)
        logical,intent(in)::mask(:)
        real(kind=8),intent(in)::probcat(:),probcatobs(:)
        real(kind=8)::condprobvec(size(probcat))
    end function condprobvec

!	Multinomial covariance matrix.
!	density is vector of probabilities.
!	meanth is vector of means.
!	quadpoint is array of weights.
    function mcovth(density,meanth,quadpoint)
        implicit none
        real(kind=8),intent(in)::density(:),meanth(:),quadpoint(:,:)
        real(kind=8)::mcovth(size(meanth),size(meanth))
    end function mcovth
!	Multinomial mean.
!	density is vector of probabilities
!	quadpoint is array of weights.
    function mmeanth(density,quadpoint)
        implicit none
        real(kind=8),intent(in)::density(:),quadpoint(:,:)
        real(kind=8)::mmeanth(size(quadpoint,1))
    end function mmeanth
!	probvec is used to compute underlying item probabilities.
!   numcat indicates the number of underlying categories per item.
!	mask indicates which items were presented.
!	locations provides location parameters and scales provides scale factors.
!	theta is the value of the latent vector.
    function probvec(numcat,mask,locations,scales,theta)
        implicit none
        integer,intent(in)::numcat(:)
        logical,intent(in)::mask(:)
        real(kind=8),intent(in)::locations(:),scales(:,:),theta(:)
        real(kind=8)::probvec(size(locations))
    end function probvec
!	probvecobs is used to compute observed item probabilities given the latent vector.
!	catobsrange is the table of ranges of underlying categories per observed category.
!	numcatobs provides the number of observed categories per item.
!	resp is the response vector.
!	mask indicates which items were presented.
!	probcat is the vector of underlying item probabilities.
    function probvecobs(catobsrange,numcatobs,resp,mask,probcat)
        implicit none

        integer,intent(in)::catobsrange(:,:),numcatobs(:),resp(:)
        logical,intent(in)::mask(:)
        real(kind=8),intent(in)::probcat(:)
        real(kind=8)::probvecobs(size(mask))
    end function probvecobs
end interface
integer,intent(in)::catobsrange(:,:),dat(:,:),numcat(:),numcatobs(:)

real(kind=8),intent(in)::beta(:),lintran(:,:),postdensity(:,:),theta(:,:,:),wtsum(:,:)
real(kind=8),intent(out)::covreswt(:,:,:),fitwt(:,:),obswt(:,:),reswt(:,:),sdreswt(:,:),zreswt(:,:)
!	item is an item.
!	ncat is the total number of underlying categories.
!	obs is observation number.
!   quad counts quadrature points.
!	resp is a single response.
!	row is a row counter.
!   row1 is a second row counter.

integer::item,ncat,obs,quad,resp(size(numcatobs)),row
!   datamask is for identification of item responses for observations.
logical::datamask(size(numcat))
!   condprob is for conditional probabilities of underlying responses given observed ones.
!   covar is the covariance matrix of the differences of observed and duplicate sums.
!   covquad is the covariance matrix of sums given the latent vector.
!   covquaditem is the covariance matrix of weighted sums for items given the latent vector.
!	locations is for location parameters.

!	meanquad is for means of sums for quadrature points.
!	meanquaditem is for means of sums for items and for quadrature points.
!	obsquad is for conditional means of sums for quadrature points.
!	obsquaditem is for conditional means of sums for items and for quadrature points.
!	newtheta is lintran(theta).
!	probcat is used for underlying marginal conditional probabilities.
!   probcatobs is used for marginal conditional probabilities of observations.
!	scales is for scale parameters.

real(kind=8)::condprob(sum(numcat)),covar(size(wtsum,1),size(wtsum,1))
real(kind=8)::covquad(size(wtsum,1),size(wtsum,1),size(postdensity,1)),&
    covquaditem(size(wtsum,1),size(wtsum,1),size(numcat),size(postdensity,1))
real(kind=8)::locations(sum(numcat))
real(kind=8)::meanquad(size(wtsum,1),size(postdensity,1)),meanquaditem(size(wtsum,1),size(numcat),size(postdensity,1))
real(kind=8)::newtheta(size(lintran,1))
real(kind=8)::obsquad(size(wtsum,1),size(postdensity,1)),obsquaditem(size(wtsum,1),size(numcat),size(postdensity,1))
real(kind=8)::probcat(sum(numcat)),probcatobs(size(numcatobs))
real(kind=8)::scales(size(lintran,1),sum(numcat))

!	Set up parameter arrays for simplified processing.
ncat=sum(numcat)
!	Item scale parameters.
locations=beta(1:ncat)
scales=reshape(beta(ncat+1:ncat*(1+size(lintran,1))),(/size(lintran,1),ncat/))
covar=0.0_8
covquad=0.0_8
covquaditem=0.0_8
covreswt=0.0_8
fitwt=0.0_8
obswt=0.0_8
reswt=0.0_8
sdreswt=0.0_8
zreswt=0.0_8

!	Obtain results for each observation.
obsloop:do obs=1,size(postdensity,2)

    resp=dat(:,obs)

    datamask=.false.
    do item=1,size(numcat)
        if(resp(item)>=0.and.resp(item)<numcatobs(item))datamask(item)=.true.
    end do

!	Cycle through quadrature points.
    covquad=0.0_8
    covquaditem=0.0_8
    meanquad=0.0_8
    meanquaditem=0.0_8
    obsquad=0.0_8
    obsquaditem=0.0_8

	covar=0.0_8
    do quad=1,size(postdensity,1)
        newtheta=matmul(lintran,theta(:,quad,obs))

! Probability computation.

        probcat=probvec(numcat,datamask,locations,scales,newtheta)
        probcatobs=probvecobs(catobsrange,numcatobs,resp,datamask,probcat)
        condprob=condprobvec(catobsrange,numcatobs,resp,datamask,probcat,probcatobs)
        if(size(wtsum,1)>0)then
            row=1

            do item=1,size(numcat)
                if(.not.datamask(item).and.any(wtsum(:,row:row+numcat(item)-1)/=0.0_8))&
                    cycle obsloop
                if(datamask(item)) then
                    meanquaditem(:,item,quad)=mmeanth(probcat(row:row+numcat(item)-1),wtsum(:,row:row+numcat(item)-1))
                    meanquad(:,quad)=meanquad(:,quad)+meanquaditem(:,item,quad)
                    obsquaditem(:,item,quad)=mmeanth(condprob(row:row+numcat(item)-1),wtsum(:,row:row+numcat(item)-1))
                    obsquad(:,quad)=obsquad(:,quad)+obsquaditem(:,item,quad)
                    covquaditem(:,:,item,quad)=&
                        mcovth(probcat(row:row+numcat(item)-1),meanquaditem(:,item,quad),wtsum(:,row:row+numcat(item)-1))&
                        +mcovth(condprob(row:row+numcat(item)-1),obsquaditem(:,item,quad),wtsum(:,row:row+numcat(item)-1))
                    covquad(:,:,quad)=covquad(:,:,quad)+covquaditem(:,:,item,quad)

                end if

                row=row+numcat(item)
            end do
            covar=covar+postdensity(quad,obs)*covquad(:,:,quad)

        end if
    end do

!	mean and covariance.
    fitwt(:,obs)=mmeanth(postdensity(:,obs),meanquad)
    obswt(:,obs)=mmeanth(postdensity(:,obs),obsquad)

    reswt(:,obs)=obswt(:,obs)-fitwt(:,obs)
    covreswt(:,:,obs)=mcovth(postdensity(:,obs),fitwt(:,obs),meanquad)+covar
    do row=1,size(wtsum,1)
        sdreswt(row,obs)=sqrt(covreswt(row,row,obs))
        if(sdreswt(row,obs)>0.0_8)zreswt(row,obs)=reswt(row,obs)/sdreswt(row,obs)
    end do
end do obsloop
return
end subroutine reswtsum