      SUBROUTINE CFFTF (N,C,WSAVE)
C***BEGIN PROLOGUE  CFFTF
C***REVISION DATE  811015   (YYMMDD)
C***CATEGORY NO.  D6
C***KEYWORDS FFT,FAST FOURIER TRANSFORM,COMPLEX
C***DATE WRITTEN  FEBRUARY 1978
C***AUTHOR  SWARZTRAUBER P.N. (NCAR)
C***PURPOSE
C  FORWARD FFT OF A COMPLEX PERIODIC SEQUENCE
C***DESCRIPTION
C     *****************************************************************
C
C     SUBROUTINE CFFTF(N,C,WSAVE)
C
C     *****************************************************************
C
C     SUBROUTINE CFFTF COMPUTES THE FORWARD COMPLEX DISCRETE FOURIER
C     TRANSFORM (THE FOURIER ANALYSIS). EQUIVALENTLY , CFFTF COMPUTES
C     THE FOURIER COEFFICIENTS OF A COMPLEX PERIODIC SEQUENCE.
C     THE TRANSFORM IS DEFINED BELOW AT OUTPUT PARAMETER C.
C
C     THE TRANSFORM IS NOT NORMALIZED. TO OBTAIN A NORMALIZED TRANSFORM
C     THE OUTPUT MUST BE DIVIDED BY N. OTHERWISE A CALL OF CFFTF
C     FOLLOWED BY A CALL OF CFFTB WILL MULTIPLY THE SEQUENCE BY N.
C
C     THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE CFFTF MUST BE
C     INITIALIZED BY CALLING SUBROUTINE CFFTI(N,WSAVE).
C
C     INPUT PARAMETERS
C
C
C     N      THE LENGTH OF THE COMPLEX SEQUENCE C. THE METHOD IS
C            MORE EFFICIENT WHEN N IS THE PRODUCT OF SMALL PRIMES. N
C
C     C      A COMPLEX ARRAY OF LENGTH N WHICH CONTAINS THE SEQUENCE
C
C     WSAVE   A REAL WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 4N+1
C             IN THE PROGRAM THAT CALLS CFFTF. THE WSAVE ARRAY MUST BE
C             INITIALIZED BY CALLING SUBROUTINE CFFTI(N,WSAVE) AND A
C             DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT
C             VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE
C             REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT
C             TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST.
C             THE SAME WSAVE ARRAY CAN BE USED BY CFFTF AND CFFTB.
C
C     OUTPUT PARAMETERS
C
C     C      FOR J=1,...,N
C
C                C(J)=THE SUM FROM K=1,...,N OF
C
C                      C(K)*EXP(-I*J*K*2*PI/N)
C
C                            WHERE I=SQRT(-1)
C
C     WSAVE   CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT BE
C             DESTROYED BETWEEN CALLS OF SUBROUTINE CFFTF OR CFFTB
C
C***REFERENCES
C***ROUTINES CALLED  CFFTF1
C***END PROLOGUE  CFFTF
      DIMENSION       C(1)       ,WSAVE(1)
C***FIRST EXECUTABLE STATEMENT  CFFTF
      IF (N .EQ. 1) RETURN
      IW1 = N+N+1
      IW2 = IW1+N+N
      CALL CFFTF1 (N,C,WSAVE,WSAVE(IW1),WSAVE(IW2))
      RETURN
      END
C
C****************************
C
      SUBROUTINE CFFTF1 (N,C,CH,WA,IFAC)
C***BEGIN PROLOGUE  CFFTF1
C***REFER TO CFFTF
C***ROUTINES CALLED  PASSF,PASSF5,PASSF3,PASSF2,PASSF4
C***END PROLOGUE  CFFTF1
      DIMENSION       CH(1)      ,C(1)       ,WA(1)      ,IFAC(1)
C***FIRST EXECUTABLE STATEMENT  CFFTF1
      NF = IFAC(2)
      NA = 0
      L1 = 1
      IW = 1
      DO 116 K1=1,NF
         IP = IFAC(K1+2)
         L2 = IP*L1
         IDO = N/L2
         IDOT = IDO+IDO
         IDL1 = IDOT*L1
         IF (IP .NE. 4) GO TO 103
         IX2 = IW+IDOT
         IX3 = IX2+IDOT
         IF (NA .NE. 0) GO TO 101
         CALL PASSF4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
         GO TO 102
  101    CALL PASSF4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
  102    NA = 1-NA
         GO TO 115
  103    IF (IP .NE. 2) GO TO 106
         IF (NA .NE. 0) GO TO 104
         CALL PASSF2 (IDOT,L1,C,CH,WA(IW))
         GO TO 105
  104    CALL PASSF2 (IDOT,L1,CH,C,WA(IW))
  105    NA = 1-NA
         GO TO 115
  106    IF (IP .NE. 3) GO TO 109
         IX2 = IW+IDOT
         IF (NA .NE. 0) GO TO 107
         CALL PASSF3 (IDOT,L1,C,CH,WA(IW),WA(IX2))
         GO TO 108
  107    CALL PASSF3 (IDOT,L1,CH,C,WA(IW),WA(IX2))
  108    NA = 1-NA
         GO TO 115
  109    IF (IP .NE. 5) GO TO 112
         IX2 = IW+IDOT
         IX3 = IX2+IDOT
         IX4 = IX3+IDOT
         IF (NA .NE. 0) GO TO 110
         CALL PASSF5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
         GO TO 111
  110    CALL PASSF5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
  111    NA = 1-NA
         GO TO 115
  112    IF (NA .NE. 0) GO TO 113
         CALL PASSF (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
         GO TO 114
  113    CALL PASSF (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
  114    IF (NAC .NE. 0) NA = 1-NA
  115    L1 = L2
         IW = IW+(IP-1)*IDOT
  116 CONTINUE
      IF (NA .EQ. 0) RETURN
      N2 = N+N
      DO 117 I=1,N2
         C(I) = CH(I)
  117 CONTINUE
      RETURN
      END
C
C********************************************************************
C
      SUBROUTINE CFFTI (N,WSAVE)
C***BEGIN PROLOGUE  CFFTI
C***REVISION DATE  811015   (YYMMDD)
C***CATEGORY NO.  D6
C***KEYWORDS FFT,FAST FOURIER TRANSFORM,FOURIER TRANSFORM,COMPLEX
C***DATE WRITTEN  FEBRUARY 1978
C***AUTHOR  SWARZTRAUBER P.N. (NCAR)
C***PURPOSE
C   INITIALIZE FOR CFFTF AND CFFTB
C***DESCRIPTION
C     *****************************************************************
C
C     SUBROUTINE CFFTI(N,WSAVE)
C
C     *****************************************************************
C
C     SUBROUTINE CFFTI INITIALIZES THE ARRAY WSAVE WHICH IS USED IN
C     BOTH CFFTF AND CFFTB. THE PRIME FACTORIZATION OF N TOGETHER WITH
C     A TABULATION OF THE TRIGONOMETRIC FUNCTIONS ARE COMPUTED AND
C     STORED IN WSAVE.
C
C     INPUT PARAMETER
C
C     N       THE LENGTH OF THE SEQUENCE TO BE TRANSFORMED
C
C     OUTPUT PARAMETER
C
C     WSAVE   A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 4*N+15
C             THE SAME WORK ARRAY CAN BE USED FOR BOTH CFFTF AND CFFTB
C             AS LONG AS N REMAINS UNCHANGED. DIFFERENT WSAVE ARRAYS
C             ARE REQUIRED FOR DIFFERENT VALUES OF N. THE CONTENTS OF
C             WSAVE MUST NOT BE CHANGED BETWEEN CALLS OF CFFTF OR CFFTB
C
C***REFERENCES
C***ROUTINES CALLED  CFFTI1
C***END PROLOGUE  CFFTI
      DIMENSION       WSAVE(1)
C***FIRST EXECUTABLE STATEMENT  CFFTI
      IF (N .EQ. 1) RETURN
      IW1 = N+N+1
      IW2 = IW1+N+N
      CALL CFFTI1 (N,WSAVE(IW1),WSAVE(IW2))
      RETURN
      END
C
C************************************************
C
      SUBROUTINE CFFTI1 (N,WA,IFAC)
C***BEGIN PROLOGUE  CFFTI1
C***REFER TO CFFTI
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  CFFTI1
      DIMENSION       WA(1)      ,IFAC(1)    ,NTRYH(4)
      DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/3,4,2,5/
C***FIRST EXECUTABLE STATEMENT  CFFTI1
      NL = N
      NF = 0
      J = 0
  101 J = J+1
      IF (J-4) 102,102,103
  102 NTRY = NTRYH(J)
      GO TO 104
  103 NTRY = NTRY+2
  104 NQ = NL/NTRY
      NR = NL-NTRY*NQ
      IF (NR) 101,105,101
  105 NF = NF+1
      IFAC(NF+2) = NTRY
      NL = NQ
      IF (NTRY .NE. 2) GO TO 107
      IF (NF .EQ. 1) GO TO 107
      DO 106 I=2,NF
         IB = NF-I+2
         IFAC(IB+2) = IFAC(IB+1)
  106 CONTINUE
      IFAC(3) = 2
  107 IF (NL .NE. 1) GO TO 104
      IFAC(1) = N
      IFAC(2) = NF
      TPI = 6.28318530717959
      ARGH = TPI/FLOAT(N)
      I = 2
      L1 = 1
      DO 110 K1=1,NF
         IP = IFAC(K1+2)
         LD = 0
         L2 = L1*IP
         IDO = N/L2
         IDOT = IDO+IDO+2
         IPM = IP-1
         WLDC = 1.
         WLDS = 0.
         ARG = FLOAT(L1)*ARGH
         DL1C = COS(ARG)
         DL1S = SIN(ARG)
         DO 109 J=1,IPM
            I1 = I
            WA(I-1) = 1.
            WA(I) = 0.
            LD = LD+L1
            WLDCH = WLDC
            WLDC = DL1C*WLDC-DL1S*WLDS
            WLDS = DL1S*WLDCH+DL1C*WLDS
            DC = WLDC
            DS = WLDS
            DO 108 II=4,IDOT,2
               I = I+2
               WA(I-1) = DC*WA(I-3)-DS*WA(I-2)
               WA(I) = DS*WA(I-3)+DC*WA(I-2)
  108       CONTINUE
            IF (IP .LE. 5) GO TO 109
            WA(I1-1) = WA(I-1)
            WA(I1) = WA(I)
  109    CONTINUE
         L1 = L2
  110 CONTINUE
      RETURN
      END
c
c**********************************************
c
        subroutine fftnp2(n,m,x,z,wsave)
c
c
c       computes discreet fourier transforms of time series
c       in x; variables:
c               x(m,n) = array of m channels of time series
c                 of length n=2**l2n on input;  on output
c                 x contains the transform in a compact form
c                 using the symmetry implied by the real
c                 form of x; the output form is:
c                       x(j,2k-1)= real part of transform
c                               for frequency k/n
c                       x(j,2k)= imag. part of tran.
c                               for freq. k/n
c                 negative frequencies are obtained as complex
c                 conjugates of pos. frequencies
c               z(2,n) =  work space; should be z(2,2n)
C               wsave(*) = array containing prime factors, tables
c                         for FFT
        real x(m,n),z(2,n),wsave(*)

c
        n2=int(n/2+.5)

c
          do 100 j=1,m,2
c
        if (j.eq.m) go to 20
c
           do 15 i=1,n
           z(1,i)=x(j,i)
           z(2,i)=x(j+1,i)
15         continue
           go to 30
c
20         do 25 i=1,n
           z(1,i)=x(m,i)
           z(2,i)=0.
25         continue
c
30      continue

           call CFFTF(n,z,wsave)

        if(j.eq.m)go to 50
c
           do 40 i=2,n2+1
           mi=n-i+2
           k2=2*(i-1)
           k1=k2-1
           x(j,k1)=(z(1,i)+z(1,mi))/2.
           x(j,k2)=(z(2,i)-z(2,mi))/2.
           x(j+1,k1)=(z(2,i)+z(2,mi))/2.
           x(j+1,k2)=(z(1,mi)-z(1,i))/2.
40         continue
        go to 60

50      continue

           do 55 i=2,n2+1
           k2=2*(i-1)
           k1=k2-1
           x(m,k1)=z(1,i)
           x(m,k2)=z(2,i)
55         continue

60      continue
100     continue
        return
        end
C
C*****************************************
C
      SUBROUTINE PASSF (NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)
C***BEGIN PROLOGUE  PASSF
C***REFER TO CFFTF
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  PASSF
      DIMENSION       CH(IDO,L1,IP)          ,CC(IDO,IP,L1)          ,
     1                C1(IDO,L1,IP)          ,WA(1)      ,C2(IDL1,IP),
     2                CH2(IDL1,IP)
C***FIRST EXECUTABLE STATEMENT  PASSF
      IDOT = IDO/2
      NT = IP*IDL1
      IPP2 = IP+2
      IPPH = (IP+1)/2
      IDP = IP*IDO
C
      IF (IDO .LT. L1) GO TO 106
      DO 103 J=2,IPPH
         JC = IPP2-J
         DO 102 K=1,L1
            DO 101 I=1,IDO
               CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)
               CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)
  101       CONTINUE
  102    CONTINUE
  103 CONTINUE
      DO 105 K=1,L1
         DO 104 I=1,IDO
            CH(I,K,1) = CC(I,1,K)
  104    CONTINUE
  105 CONTINUE
      GO TO 112
  106 DO 109 J=2,IPPH
         JC = IPP2-J
         DO 108 I=1,IDO
            DO 107 K=1,L1
               CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)
               CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)
  107       CONTINUE
  108    CONTINUE
  109 CONTINUE
      DO 111 I=1,IDO
         DO 110 K=1,L1
            CH(I,K,1) = CC(I,1,K)
  110    CONTINUE
  111 CONTINUE
  112 IDL = 2-IDO
      INC = 0
      DO 116 L=2,IPPH
         LC = IPP2-L
         IDL = IDL+IDO
         DO 113 IK=1,IDL1
            C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2)
            C2(IK,LC) = -WA(IDL)*CH2(IK,IP)
  113    CONTINUE
         IDLJ = IDL
         INC = INC+IDO
         DO 115 J=3,IPPH
            JC = IPP2-J
            IDLJ = IDLJ+INC
            IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP
            WAR = WA(IDLJ-1)
            WAI = WA(IDLJ)
            DO 114 IK=1,IDL1
               C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J)
               C2(IK,LC) = C2(IK,LC)-WAI*CH2(IK,JC)
  114       CONTINUE
  115    CONTINUE
  116 CONTINUE
      DO 118 J=2,IPPH
         DO 117 IK=1,IDL1
            CH2(IK,1) = CH2(IK,1)+CH2(IK,J)
  117    CONTINUE
  118 CONTINUE
      DO 120 J=2,IPPH
         JC = IPP2-J
         DO 119 IK=2,IDL1,2
            CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC)
            CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC)
            CH2(IK,J) = C2(IK,J)+C2(IK-1,JC)
            CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC)
  119    CONTINUE
  120 CONTINUE
      NAC = 1
      IF (IDO .EQ. 2) RETURN
      NAC = 0
      DO 121 IK=1,IDL1
         C2(IK,1) = CH2(IK,1)
  121 CONTINUE
      DO 123 J=2,IP
         DO 122 K=1,L1
            C1(1,K,J) = CH(1,K,J)
            C1(2,K,J) = CH(2,K,J)
  122    CONTINUE
  123 CONTINUE
      IF (IDOT .GT. L1) GO TO 127
      IDIJ = 0
      DO 126 J=2,IP
         IDIJ = IDIJ+2
         DO 125 I=4,IDO,2
            IDIJ = IDIJ+2
            DO 124 K=1,L1
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J)
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J)
  124       CONTINUE
  125    CONTINUE
  126 CONTINUE
      RETURN
  127 IDJ = 2-IDO
      DO 130 J=2,IP
         IDJ = IDJ+IDO
         DO 129 K=1,L1
            IDIJ = IDJ
            DO 128 I=4,IDO,2
               IDIJ = IDIJ+2
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J)
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J)
  128       CONTINUE
  129    CONTINUE
  130 CONTINUE
      RETURN
      END
C
C*********************************************
C
      SUBROUTINE PASSF2 (IDO,L1,CC,CH,WA1)
C***BEGIN PROLOGUE  PASSF2
C***REFER TO CFFTF
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  PASSF2
      DIMENSION       CC(IDO,2,L1)           ,CH(IDO,L1,2)           ,
     1                WA1(1)
C***FIRST EXECUTABLE STATEMENT  PASSF2
      IF (IDO .GT. 2) GO TO 102
      DO 101 K=1,L1
         CH(1,K,1) = CC(1,1,K)+CC(1,2,K)
         CH(1,K,2) = CC(1,1,K)-CC(1,2,K)
         CH(2,K,1) = CC(2,1,K)+CC(2,2,K)
         CH(2,K,2) = CC(2,1,K)-CC(2,2,K)
  101 CONTINUE
      RETURN
  102 DO 104 K=1,L1
         DO 103 I=2,IDO,2
            CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K)
            TR2 = CC(I-1,1,K)-CC(I-1,2,K)
            CH(I,K,1) = CC(I,1,K)+CC(I,2,K)
            TI2 = CC(I,1,K)-CC(I,2,K)
            CH(I,K,2) = WA1(I-1)*TI2-WA1(I)*TR2
            CH(I-1,K,2) = WA1(I-1)*TR2+WA1(I)*TI2
  103    CONTINUE
  104 CONTINUE
      RETURN
      END
C
C*******************************************
C
      SUBROUTINE PASSF3 (IDO,L1,CC,CH,WA1,WA2)
C***BEGIN PROLOGUE  PASSF3
C***REFER TO CFFTF
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  PASSF3
      DIMENSION       CC(IDO,3,L1)           ,CH(IDO,L1,3)           ,
     1                WA1(1)     ,WA2(1)
      DATA TAUR,TAUI /-.5,-.866025403784439/
C***FIRST EXECUTABLE STATEMENT  PASSF3
      IF (IDO .NE. 2) GO TO 102
      DO 101 K=1,L1
         TR2 = CC(1,2,K)+CC(1,3,K)
         CR2 = CC(1,1,K)+TAUR*TR2
         CH(1,K,1) = CC(1,1,K)+TR2
         TI2 = CC(2,2,K)+CC(2,3,K)
         CI2 = CC(2,1,K)+TAUR*TI2
         CH(2,K,1) = CC(2,1,K)+TI2
         CR3 = TAUI*(CC(1,2,K)-CC(1,3,K))
         CI3 = TAUI*(CC(2,2,K)-CC(2,3,K))
         CH(1,K,2) = CR2-CI3
         CH(1,K,3) = CR2+CI3
         CH(2,K,2) = CI2+CR3
         CH(2,K,3) = CI2-CR3
  101 CONTINUE
      RETURN
  102 DO 104 K=1,L1
         DO 103 I=2,IDO,2
            TR2 = CC(I-1,2,K)+CC(I-1,3,K)
            CR2 = CC(I-1,1,K)+TAUR*TR2
            CH(I-1,K,1) = CC(I-1,1,K)+TR2
            TI2 = CC(I,2,K)+CC(I,3,K)
            CI2 = CC(I,1,K)+TAUR*TI2
            CH(I,K,1) = CC(I,1,K)+TI2
            CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K))
            CI3 = TAUI*(CC(I,2,K)-CC(I,3,K))
            DR2 = CR2-CI3
            DR3 = CR2+CI3
            DI2 = CI2+CR3
            DI3 = CI2-CR3
            CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2
            CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2
            CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3
            CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3
  103    CONTINUE
  104 CONTINUE
      RETURN
      END
C
C*********************************************
C
      SUBROUTINE PASSF4 (IDO,L1,CC,CH,WA1,WA2,WA3)
C***BEGIN PROLOGUE  PASSF4
C***REFER TO CFFTF
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  PASSF4
      DIMENSION       CC(IDO,4,L1)           ,CH(IDO,L1,4)           ,
     1                WA1(1)     ,WA2(1)     ,WA3(1)
C***FIRST EXECUTABLE STATEMENT  PASSF4
      IF (IDO .NE. 2) GO TO 102
      DO 101 K=1,L1
         TI1 = CC(2,1,K)-CC(2,3,K)
         TI2 = CC(2,1,K)+CC(2,3,K)
         TR4 = CC(2,2,K)-CC(2,4,K)
         TI3 = CC(2,2,K)+CC(2,4,K)
         TR1 = CC(1,1,K)-CC(1,3,K)
         TR2 = CC(1,1,K)+CC(1,3,K)
         TI4 = CC(1,4,K)-CC(1,2,K)
         TR3 = CC(1,2,K)+CC(1,4,K)
         CH(1,K,1) = TR2+TR3
         CH(1,K,3) = TR2-TR3
         CH(2,K,1) = TI2+TI3
         CH(2,K,3) = TI2-TI3
         CH(1,K,2) = TR1+TR4
         CH(1,K,4) = TR1-TR4
         CH(2,K,2) = TI1+TI4
         CH(2,K,4) = TI1-TI4
  101 CONTINUE
      RETURN
  102 DO 104 K=1,L1
         DO 103 I=2,IDO,2
            TI1 = CC(I,1,K)-CC(I,3,K)
            TI2 = CC(I,1,K)+CC(I,3,K)
            TI3 = CC(I,2,K)+CC(I,4,K)
            TR4 = CC(I,2,K)-CC(I,4,K)
            TR1 = CC(I-1,1,K)-CC(I-1,3,K)
            TR2 = CC(I-1,1,K)+CC(I-1,3,K)
            TI4 = CC(I-1,4,K)-CC(I-1,2,K)
            TR3 = CC(I-1,2,K)+CC(I-1,4,K)
            CH(I-1,K,1) = TR2+TR3
            CR3 = TR2-TR3
            CH(I,K,1) = TI2+TI3
            CI3 = TI2-TI3
            CR2 = TR1+TR4
            CR4 = TR1-TR4
            CI2 = TI1+TI4
            CI4 = TI1-TI4
            CH(I-1,K,2) = WA1(I-1)*CR2+WA1(I)*CI2
            CH(I,K,2) = WA1(I-1)*CI2-WA1(I)*CR2
            CH(I-1,K,3) = WA2(I-1)*CR3+WA2(I)*CI3
            CH(I,K,3) = WA2(I-1)*CI3-WA2(I)*CR3
            CH(I-1,K,4) = WA3(I-1)*CR4+WA3(I)*CI4
            CH(I,K,4) = WA3(I-1)*CI4-WA3(I)*CR4
  103    CONTINUE
  104 CONTINUE
      RETURN
      END
C
C*******************************
C
      SUBROUTINE PASSF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4)
C***BEGIN PROLOGUE  PASSF5
C***REFER TO CFFTF
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  PASSF5
      DIMENSION       CC(IDO,5,L1)           ,CH(IDO,L1,5)           ,
     1                WA1(1)     ,WA2(1)     ,WA3(1)     ,WA4(1)
      DATA TR11,TI11,TR12,TI12 /.309016994374947,-.951056516295154,
     1-.809016994374947,-.587785252292473/
C***FIRST EXECUTABLE STATEMENT  PASSF5
      IF (IDO .NE. 2) GO TO 102
      DO 101 K=1,L1
         TI5 = CC(2,2,K)-CC(2,5,K)
         TI2 = CC(2,2,K)+CC(2,5,K)
         TI4 = CC(2,3,K)-CC(2,4,K)
         TI3 = CC(2,3,K)+CC(2,4,K)
         TR5 = CC(1,2,K)-CC(1,5,K)
         TR2 = CC(1,2,K)+CC(1,5,K)
         TR4 = CC(1,3,K)-CC(1,4,K)
         TR3 = CC(1,3,K)+CC(1,4,K)
         CH(1,K,1) = CC(1,1,K)+TR2+TR3
         CH(2,K,1) = CC(2,1,K)+TI2+TI3
         CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3
         CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3
         CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3
         CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3
         CR5 = TI11*TR5+TI12*TR4
         CI5 = TI11*TI5+TI12*TI4
         CR4 = TI12*TR5-TI11*TR4
         CI4 = TI12*TI5-TI11*TI4
         CH(1,K,2) = CR2-CI5
         CH(1,K,5) = CR2+CI5
         CH(2,K,2) = CI2+CR5
         CH(2,K,3) = CI3+CR4
         CH(1,K,3) = CR3-CI4
         CH(1,K,4) = CR3+CI4
         CH(2,K,4) = CI3-CR4
         CH(2,K,5) = CI2-CR5
  101 CONTINUE
      RETURN
  102 DO 104 K=1,L1
         DO 103 I=2,IDO,2
            TI5 = CC(I,2,K)-CC(I,5,K)
            TI2 = CC(I,2,K)+CC(I,5,K)
            TI4 = CC(I,3,K)-CC(I,4,K)
            TI3 = CC(I,3,K)+CC(I,4,K)
            TR5 = CC(I-1,2,K)-CC(I-1,5,K)
            TR2 = CC(I-1,2,K)+CC(I-1,5,K)
            TR4 = CC(I-1,3,K)-CC(I-1,4,K)
            TR3 = CC(I-1,3,K)+CC(I-1,4,K)
            CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3
            CH(I,K,1) = CC(I,1,K)+TI2+TI3
            CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3
            CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3
            CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3
            CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3
            CR5 = TI11*TR5+TI12*TR4
            CI5 = TI11*TI5+TI12*TI4
            CR4 = TI12*TR5-TI11*TR4
            CI4 = TI12*TI5-TI11*TI4
            DR3 = CR3-CI4
            DR4 = CR3+CI4
            DI3 = CI3+CR4
            DI4 = CI3-CR4
            DR5 = CR2+CI5
            DR2 = CR2-CI5
            DI5 = CI2-CR5
            DI2 = CI2+CR5
            CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2
            CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2
            CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3
            CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3
            CH(I-1,K,4) = WA3(I-1)*DR4+WA3(I)*DI4
            CH(I,K,4) = WA3(I-1)*DI4-WA3(I)*DR4
            CH(I-1,K,5) = WA4(I-1)*DR5+WA4(I)*DI5
            CH(I,K,5) = WA4(I-1)*DI5-WA4(I)*DR5
  103    CONTINUE
  104 CONTINUE
      RETURN
      END
c
c***************************************
c
        subroutine ps1win(x,nch,npts,lwinst,w)

        real x(nch,npts),w(npts)
        logical lwinst

        parameter(p1=5.3476939016920851e-11,p2=2.2654256220146656e-9,
     1  p3=7.8075102004229667e-8,p4=2.1373409644281953e-6,
     2  p5=4.5094847544714943e-5,p6=7.0498957221483167e-4,
     3  p7=7.7412693304064753e-3,p8=5.5280627452077586e-2,
     4  p9=2.2753754228751827e-1,p10=4.3433904277546202e-1,
     5  p11=2.2902051859068017e-1)

        if(lwinst) then
           np2=(npts+1)/2
           d=sqrt(2./float(npts))
           do 20 i=1,np2
           xt=(2.*i-1.)/npts-1.
           u=(1.-xt)*(1.+xt)
           w(i)=((((((((((p1*u+p2)*u+p3)*u+p4)*u+p5)*u+p6)*u+p7)*u+p8)
     1        *u+p9)*u+p10)*u+p11)*d
           w(npts-i+1) = w(i)
20         continue

c               print*,'w',w

           lwinst = .false.
        end if

           do 50 i=1,nch
           do 50 j=1,npts
           x(i,j)=x(i,j)*w(j)
50         continue

        return
        end


	program matrix_lib
	parameter (n=700)
	real a(n,n), b(n,n), c(n,n)

c initialise
	do i=1,n
	  do j=1,n
	    a(i,j) = 1.0/float(i+j)
	    b(i,j) = 1.0/float(i) + 1.0/float(j)
	  enddo
	enddo

	call sgemm('n', 'n', n, n, n, 1.0, a, n, b, n, 0.0, c, n)
	print*,c(10,10)
	stop
	end


      subroutine genrif(p,i1,i2,i7,r1,r2,phit,wt5_4,*)
c----i1 is an initial state vector.
      implicit none
      include 'constants.f'
      include 'debug.f'
      include 'xmin.f'
      integer i1,i2,i7,j
      double precision p(mxpart,4),rtalbe,c(4),d(4),phi,phit,wt5_4,
     . jacbit,dot,r1,r2
      double precision beta,alpha
      double precision x,omx,omxmin,wt0
      parameter(wt0=1d0/eight/pisq)

c------initial final

      phi=twopi*phit
      omxmin=one-xmin

c -xx(i1)
      omx=omxmin*r1**2
      x=one-omx
      if (r2 .lt. 0.5d0) alpha=(two*r2)**2
      if (r2 .gt. 0.5d0) alpha=one-(two*r2-one)**2

      jacbit=four*r1/(half/sqrt(alpha)+half/sqrt(one-alpha))

      wt5_4=wt0*dot(p,i1,i2)/x**2*omxmin*jacbit
      if (debug) write(6,*) 'i1 in genrif',i1
      if (debug) write(6,*) 'i2 in genrif',i2
      if (debug) write(6,*) 'x in genrif',x
      if (debug) write(6,*) 'omxmin in genrif',omxmin
      if (debug) write(6,*) 'wt5_4 in genrif',wt5_4
      beta=omx*(1d0-alpha)/x
      rtalbe=sqrt(beta*alpha)
c---generate transverse vectors c and d with length^2=rtalbe^2*2*p1Dp2
c-- with direction in transverse plane picked by 6
      call gtperp(rtalbe,p,i1,i2,6,c,d)

      do j=1,4
c---sudakov in terms of original variables
      p(i7,j)=alpha*p(i2,j)+beta*p(i1,j)+cos(phi)*c(j)+sin(phi)*d(j)
      p(i1,j)=p(i1,j)/x
      p(i2,j)=p(i2,j)-p(i7,j)+omx*p(i1,j)
      enddo

c---we have now finished generating momenta and can return
      return
      end


C-----------------------------------------------------------------------
      SUBROUTINE SPTGPTVD(IROMB,MAXWV,KMAX,NMAX,
     &                    KWSKIP,KGSKIP,NRSKIP,NGSKIP,
     &                    RLAT,RLON,WAVED,WAVEZ,
     &                    DP,ZP,UP,VP,UXP,VXP,UYP,VYP)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:  SPTGPTVD   TRANSFORM SPECTRAL VECTOR TO STATION POINTS
C   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-02-29
C
C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM
C           FROM SPECTRAL COEFFICIENTS OF DIVERGENCES AND CURLS
C           TO SPECIFIED SETS OF STATION POINT VECTORS AND THEIR
C           GRADIENTS ON THE GLOBE.
C             DP=(D(UP)/DLON+D(VP*CLAT)/DLAT)/(R*CLAT)
C             ZP=(D(VP)/DLON-D(UP*CLAT)/DLAT)/(R*CLAT)
C             UXP=D(UP*CLAT)/DLON/(R*CLAT)
C             VXP=D(VP*CLAT)/DLON/(R*CLAT)
C             UYP=D(UP*CLAT)/DLAT/R
C             VYP=D(VP*CLAT)/DLAT/R
C           THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL.
C           THE WAVE AND POINT FIELDS MAY HAVE GENERAL INDEXING,
C           BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER',
C           I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX.
C           THE TRANSFORMS ARE ALL MULTIPROCESSED OVER STATIONS.
C           TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION.
C           SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
C
C PROGRAM HISTORY LOG:
C   96-02-29  IREDELL
C 1998-12-15  IREDELL  OPENMP DIRECTIVES INSERTED
C 1999-08-18  IREDELL  OPENMP DIRECTIVE TYPO FIXED
C
C USAGE:    CALL SPTGPTVD(IROMB,MAXWV,KMAX,NMAX,
C    &                    KWSKIP,KGSKIP,NRSKIP,NGSKIP,
C    &                    RLAT,RLON,WAVED,WAVEZ,
C    &                    DP,ZP,UP,VP,UXP,VXP,UYP,VYP)
C   INPUT ARGUMENTS:
C     IROMB    - INTEGER SPECTRAL DOMAIN SHAPE
C                (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL)
C     MAXWV    - INTEGER SPECTRAL TRUNCATION
C     KMAX     - INTEGER NUMBER OF FIELDS TO TRANSFORM.
C     NMAX     - INTEGER NUMBER OF STATION POINTS TO RETURN
C     KWSKIP   - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS
C                (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0)
C     KGSKIP   - INTEGER SKIP NUMBER BETWEEN STATION POINT SETS
C                (DEFAULTS TO NMAX IF KGSKIP=0)
C     NRSKIP   - INTEGER SKIP NUMBER BETWEEN STATION LATS AND LONS
C                (DEFAULTS TO 1 IF NRSKIP=0)
C     NGSKIP   - INTEGER SKIP NUMBER BETWEEN STATION POINTS
C                (DEFAULTS TO 1 IF NGSKIP=0)
C     RLAT     - REAL (*) STATION LATITUDES IN DEGREES
C     RLON     - REAL (*) STATION LONGITUDES IN DEGREES
C     WAVED    - REAL (*) WAVE DIVERGENCE FIELDS
C     WAVEZ    - REAL (*) WAVE VORTICITY FIELDS
C   OUTPUT ARGUMENTS:
C     DP       - REAL (*) STATION POINT DIVERGENCE SETS
C     ZP       - REAL (*) STATION POINT VORTICITY SETS
C     UP       - REAL (*) STATION POINT U-WIND SETS
C     VP       - REAL (*) STATION POINT V-WIND SETS
C     UXP      - REAL (*) STATION POINT U-WIND X-GRADIENT SETS
C     VXP      - REAL (*) STATION POINT V-WIND X-GRADIENT SETS
C     UYP      - REAL (*) STATION POINT U-WIND Y-GRADIENT SETS
C     VYP      - REAL (*) STATION POINT V-WIND Y-GRADIENT SETS
C
C SUBPROGRAMS CALLED:
C   SPWGET       GET WAVE-SPACE CONSTANTS
C   SPLEGEND     COMPUTE LEGENDRE POLYNOMIALS
C   SPSYNTH      SYNTHESIZE FOURIER FROM SPECTRAL
C   SPDZ2UV      COMPUTE WINDS FROM DIVERGENCE AND VORTICITY
C   SPGRADX      COMPUTE X-GRADIENT IN FOURIER SPACE
C   SPFFTPT      COMPUTE FOURIER TRANSFORM TO GRIDPOINTS
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C
C$$$
      REAL RLAT(*),RLON(*),WAVED(*),WAVEZ(*)
      REAL DP(*),ZP(*),UP(*),VP(*),UXP(*),VXP(*),UYP(*),VYP(*)
      REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1)
      REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
      REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
      REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1)
      INTEGER MP(4*KMAX)
      REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2,4*KMAX)
      REAL WTOP(2*(MAXWV+1),4*KMAX)
      REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),PLNTOP(MAXWV+1)
      REAL F(2*MAXWV+2,2,6*KMAX),G(6*KMAX)
      PARAMETER(PI=3.14159265358979)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  CALCULATE PRELIMINARY CONSTANTS
      CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP)
      MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
      MXTOP=MAXWV+1
      MDIM=2*MX
      IDIM=2*MAXWV+2
      KW=KWSKIP
      KG=KGSKIP
      NR=NRSKIP
      NG=NGSKIP
      IF(KW.EQ.0) KW=2*MX
      IF(KG.EQ.0) KG=NMAX
      IF(NR.EQ.0) NR=1
      IF(NG.EQ.0) NG=1
      MP(1:2*KMAX)=0
      MP(2*KMAX+1:4*KMAX)=1
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  CALCULATE SPECTRAL WINDS
C$OMP PARALLEL DO PRIVATE(KWS,KD,KZ,KU,KV)
      DO K=1,KMAX
        KWS=(K-1)*KW
        KD=0*KMAX+K
        KZ=1*KMAX+K
        KU=2*KMAX+K
        KV=3*KMAX+K
        DO I=1,2*MX
          W(I,KD)=WAVED(KWS+I)
          W(I,KZ)=WAVEZ(KWS+I)
        ENDDO
        DO I=1,2*MXTOP
          WTOP(I,KD)=0
          WTOP(I,KZ)=0
        ENDDO
        CALL SPDZ2UV(IROMB,MAXWV,ENN1,ELONN1,EON,EONTOP,
     &               WAVED(KWS+1),WAVEZ(KWS+1),
     &               W(1,KU),W(1,KV),WTOP(1,KU),WTOP(1,KV))
      ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  CALCULATE STATION FIELDS
C$OMP PARALLEL DO PRIVATE(KD,KZ,KU,KV,KUX,KVX,SLAT1,CLAT1)
C$OMP&            PRIVATE(PLN,PLNTOP,F,G,NK)
      DO N=1,NMAX
        KU=2*KMAX+1
        KUX=4*KMAX+1
        IF(ABS(RLAT((N-1)*NR+1)).GE.89.9995) THEN
          SLAT1=SIGN(1.,RLAT((N-1)*NR+1))
          CLAT1=0.
        ELSE
          SLAT1=SIN(PI/180*RLAT((N-1)*NR+1))
          CLAT1=COS(PI/180*RLAT((N-1)*NR+1))
        ENDIF
        CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP,
     &                PLN,PLNTOP)
        CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,MDIM,2*MXTOP,4*KMAX,
     &               CLAT1,PLN,PLNTOP,MP,W,WTOP,F)
        CALL SPGRADX(MAXWV,IDIM,2*KMAX,MP(2*KMAX+1),CLAT1,
     &               F(1,1,2*KMAX+1),F(1,1,4*KMAX+1))
        CALL SPFFTPT(MAXWV,1,IDIM,1,6*KMAX,RLON((N-1)*NR+1),F,G)
        DO K=1,KMAX
          KD=0*KMAX+K
          KZ=1*KMAX+K
          KU=2*KMAX+K
          KV=3*KMAX+K
          KUX=4*KMAX+K
          KVX=5*KMAX+K
          NK=(N-1)*NG+(K-1)*KG+1
          DP(NK)=G(KD)
          ZP(NK)=G(KZ)
          UP(NK)=G(KU)
          VP(NK)=G(KV)
          UXP(NK)=G(KUX)
          VXP(NK)=G(KVX)
          UYP(NK)=G(KVX)-CLAT1*G(KZ)
          VYP(NK)=CLAT1*G(KD)-G(KUX)
        ENDDO
      ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      END


	SUBROUTINE rqcoal
C***********************************************************************
C 	RQCOAL CALCULATES ARRAYS OF MEAN ABORPTION AND SCATTERING
C	EFFICIENCIES FOR COAL AS A FUNCTION OF PARTICLE SIZE AND
C	TEMPERATURE. SPECTRAL EFFICIENCIES ARE CALCULATED BASED ON
C	THE SIZE PARAMETER (X) AND RELATIVE REFRACTIVE INDEX (REFREL)
C 	FOR A GIVEN SPHERE REFRACTIVE INDEX, MEDIUM REFRACTIVE INDEX,
C 	RADIUS, AND FREE SPACE WAVELENGTH USING MIE THEORY.
C 	MEAN EFFICIENCIES ARE CALCULATED AS THE AVERAGE OF THE PLANCK
C	AND ROSSELAND MEAN ABSORPTION AND SCATTERING EFFICIENCIES.
C
C	SUBROUTINES USED: RMIE, PLANCK, ROSSEL
C	CODED SEPT 1992 BY BRAD ADAMS.
C***********************************************************************
      PARAMETER (NTD = 19, NTT = 14)
      COMMON
     & /LOGR1/  LRADI,LDBRAD,LCCOEF,LRPART,LRSOOT,LRTURB,LRUSNK
     & /RQMEAN/ QACOAL(NTD,NTT),QSCOAL(NTD,NTT),QAASH(NTD,NTT),
     &          QSASH(NTD,NTT),RTDIA(NTD),RTTEMP(NTT)
     & /RUSNK/ UNCOAL,UKCOAL,UNASH,UKASH
      LOGICAL LRADI,LDBRAD,LCCOEF,LRPART,LRSOOT,LRTURB,LRUSNK
      COMPLEX REFREL,S1(200),S2(200)
      DIMENSION QA(50),QS(50),QE(50),QB(50)
      DATA PI/3.1415927/
C***********************************************************************
C  	REFMED = (REAL) REFRACTIVE INDEX OF SURROUNDING MEDIUM
C  	REFRACTIVE INDEX OF THE SPHERE = REFRE-I*REFIM
C  	RADIUS (RAD) AND WAVELENGTH (WAVEL) MUST HAVE THE SAME UNITS!
C	X = SIZE PARAMETER
C	DEFAULT REFRACTIVE INDEX IS FOR BITUMINOUS COAL, IF LRUSNK IS
C	TRUE USER INPUTS ARE USED
C***********************************************************************
	REFMED = 1.0
	IF (LRUSNK) THEN
	  REFRE = UNCOAL
	  REFIM = UKCOAL
	ELSE
	  REFRE = 1.85
	  REFIM = 0.25
	END IF
C***********************************************************************
C	SINCE COAL REFRACTIVE INDEX IS ASSUMED INDEPENDENT OF
C	TEMPERATURE, TEMPERATURE DEPENDENCY IS ONLY THROUGH PLANCK
C	AND ROSSELAND MEANS, THEREFORE SPECTRAL EFFICIENCIES ONLY NEED
C	TO BE CALCULATED ONCE FOR EACH PARTICLE DIAMETER
C***********************************************************************
	NWVL = 27
	DIAM = 0.50
	DO 300 J=1,NTD
	  RAD = DIAM / 2.
	  WAVEL = 0.250
	  DO 100 I=1,NWVL
   	    REFREL=CMPLX(REFRE,REFIM)/REFMED
   	    X=2.0*PI*RAD*REFMED/WAVEL
C***********************************************************************
C  	NANG = NUMBER OF ANGLES BETWEEN 0 AND 90 DEGREES
C  	MATRIX ELEMENTS CALCULATED AT 2*NANG-1 ANGLES
C  	INCLUDING 0, 90, AND 180 DEGREES
C***********************************************************************
   	    NANG=11
   	    DANG=1.570796327/FLOAT(NANG-1)
	    X = MIN(X,1500.)
   	    CALL RMIE(X,REFREL,NANG,S1,S2,QEXT,QSCA,QBACK)
	    QA(I) = QEXT - QSCA
	    QS(I) = QSCA
	    IF (I .EQ. 1) WAVEL = WAVEL + 0.250
	    IF (I .GT. 1) WAVEL = WAVEL + 0.500
100	  CONTINUE
C***********************************************************************
C	NOW CALCULATE PLANCK AND ROSSELAND MEAN EFFICIENCIES;
C	QCOAL'S ARE AVERAGE OF PLANCK & ROSSELAND MEANS
C***********************************************************************
	  TEMP = 250.0
	  DO 200 K=1,NTT
	    CALL PLANCK(TEMP,QA,QAP)
	    CALL PLANCK(TEMP,QS,QSP)
	    CALL ROSSEL(TEMP,QA,QAR)
	    CALL ROSSEL(TEMP,QS,QSR)
	    QACOAL(J,K) = (QAP + QAR) / 2.0
	    QSCOAL(J,K) = (QSP + QSR) / 2.0
	    RTTEMP(K) = TEMP
	    IF (K.LE.9) THEN
	      TEMP = TEMP + 150.0
	    ELSE IF (K.GT.9 .AND. K.LE.11) THEN
	      TEMP = TEMP + 200.0
	    ELSE IF (K.GT.11) THEN
	      TEMP = TEMP + 500.0
	    END IF
200	  CONTINUE
c	write (6,*) 'coal diam =',diam
c	write (6,*) 'qacoal:'
c	write (6,*) (qacoal(j,n),n=1,ntbin)
c	write (6,*) 'qscoal:'
c	write (6,*) (qscoal(j,n),n=1,ntbin)
	  RTDIA(J) = DIAM
	  IF (J.LE.2) THEN
	    DIAM = 2.0 * DIAM
	  ELSE IF (J.GT.2 .AND. J.LE.6) THEN
	    DIAM = DIAM + 2.0
	  ELSE IF (J.GT.6 .AND. J.LE.10) THEN
	    DIAM = DIAM + 2.5
	  ELSE IF (J.GT.10 .AND. J.LE.12) THEN
	    DIAM = DIAM + 5.0
	  ELSE IF (J.GT.12 .AND. J.LE.14) THEN
	    DIAM = DIAM + 10.0
	  ELSE IF (J.GT.14 .AND. J.LE.16) THEN
	    DIAM = DIAM + 25.0
	  ELSE IF (J.GT.16) THEN
	    DIAM = DIAM + 100.0
	  END IF
300	CONTINUE
C
	RETURN
   	END


*> \brief \b CPTTS2 solves a tridiagonal system of the form AX=B using the L D LH factorization computed by spttrf.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CPTTS2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE CPTTS2( IUPLO, N, NRHS, D, E, B, LDB )
*
*       .. Scalar Arguments ..
*       INTEGER            IUPLO, LDB, N, NRHS
*       ..
*       .. Array Arguments ..
*       REAL               D( * )
*       COMPLEX            B( LDB, * ), E( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CPTTS2 solves a tridiagonal system of the form
*>    A * X = B
*> using the factorization A = U**H*D*U or A = L*D*L**H computed by CPTTRF.
*> D is a diagonal matrix specified in the vector D, U (or L) is a unit
*> bidiagonal matrix whose superdiagonal (subdiagonal) is specified in
*> the vector E, and X and B are N by NRHS matrices.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] IUPLO
*> \verbatim
*>          IUPLO is INTEGER
*>          Specifies the form of the factorization and whether the
*>          vector E is the superdiagonal of the upper bidiagonal factor
*>          U or the subdiagonal of the lower bidiagonal factor L.
*>          = 1:  A = U**H *D*U, E is the superdiagonal of U
*>          = 0:  A = L*D*L**H, E is the subdiagonal of L
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the tridiagonal matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*>          NRHS is INTEGER
*>          The number of right hand sides, i.e., the number of columns
*>          of the matrix B.  NRHS >= 0.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*>          D is REAL array, dimension (N)
*>          The n diagonal elements of the diagonal matrix D from the
*>          factorization A = U**H *D*U or A = L*D*L**H.
*> \endverbatim
*>
*> \param[in] E
*> \verbatim
*>          E is COMPLEX array, dimension (N-1)
*>          If IUPLO = 1, the (n-1) superdiagonal elements of the unit
*>          bidiagonal factor U from the factorization A = U**H*D*U.
*>          If IUPLO = 0, the (n-1) subdiagonal elements of the unit
*>          bidiagonal factor L from the factorization A = L*D*L**H.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*>          B is COMPLEX array, dimension (LDB,NRHS)
*>          On entry, the right hand side vectors B for the system of
*>          linear equations.
*>          On exit, the solution vectors, X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B.  LDB >= max(1,N).
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2016
*
*> \ingroup complexPTcomputational
*
*  =====================================================================
      SUBROUTINE CPTTS2( IUPLO, N, NRHS, D, E, B, LDB )
*
*  -- LAPACK computational routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     June 2016
*
*     .. Scalar Arguments ..
      INTEGER            IUPLO, LDB, N, NRHS
*     ..
*     .. Array Arguments ..
      REAL               D( * )
      COMPLEX            B( LDB, * ), E( * )
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, J
*     ..
*     .. External Subroutines ..
      EXTERNAL           CSSCAL
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          CONJG
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IF( N.LE.1 ) THEN
         IF( N.EQ.1 )
     $      CALL CSSCAL( NRHS, 1. / D( 1 ), B, LDB )
         RETURN
      END IF
*
      IF( IUPLO.EQ.1 ) THEN
*
*        Solve A * X = B using the factorization A = U**H *D*U,
*        overwriting each right hand side vector with its solution.
*
         IF( NRHS.LE.2 ) THEN
            J = 1
    5       CONTINUE
*
*           Solve U**H * x = b.
*
            DO 10 I = 2, N
               B( I, J ) = B( I, J ) - B( I-1, J )*CONJG( E( I-1 ) )
   10       CONTINUE
*
*           Solve D * U * x = b.
*
            DO 20 I = 1, N
               B( I, J ) = B( I, J ) / D( I )
   20       CONTINUE
            DO 30 I = N - 1, 1, -1
               B( I, J ) = B( I, J ) - B( I+1, J )*E( I )
   30       CONTINUE
            IF( J.LT.NRHS ) THEN
               J = J + 1
               GO TO 5
            END IF
         ELSE
            DO 60 J = 1, NRHS
*
*              Solve U**H * x = b.
*
               DO 40 I = 2, N
                  B( I, J ) = B( I, J ) - B( I-1, J )*CONJG( E( I-1 ) )
   40          CONTINUE
*
*              Solve D * U * x = b.
*
               B( N, J ) = B( N, J ) / D( N )
               DO 50 I = N - 1, 1, -1
                  B( I, J ) = B( I, J ) / D( I ) - B( I+1, J )*E( I )
   50          CONTINUE
   60       CONTINUE
         END IF
      ELSE
*
*        Solve A * X = B using the factorization A = L*D*L**H,
*        overwriting each right hand side vector with its solution.
*
         IF( NRHS.LE.2 ) THEN
            J = 1
   65       CONTINUE
*
*           Solve L * x = b.
*
            DO 70 I = 2, N
               B( I, J ) = B( I, J ) - B( I-1, J )*E( I-1 )
   70       CONTINUE
*
*           Solve D * L**H * x = b.
*
            DO 80 I = 1, N
               B( I, J ) = B( I, J ) / D( I )
   80       CONTINUE
            DO 90 I = N - 1, 1, -1
               B( I, J ) = B( I, J ) - B( I+1, J )*CONJG( E( I ) )
   90       CONTINUE
            IF( J.LT.NRHS ) THEN
               J = J + 1
               GO TO 65
            END IF
         ELSE
            DO 120 J = 1, NRHS
*
*              Solve L * x = b.
*
               DO 100 I = 2, N
                  B( I, J ) = B( I, J ) - B( I-1, J )*E( I-1 )
  100          CONTINUE
*
*              Solve D * L**H * x = b.
*
               B( N, J ) = B( N, J ) / D( N )
               DO 110 I = N - 1, 1, -1
                  B( I, J ) = B( I, J ) / D( I ) -
     $                        B( I+1, J )*CONJG( E( I ) )
  110          CONTINUE
  120       CONTINUE
         END IF
      END IF
*
      RETURN
*
*     End of CPTTS2
*
      END


      SUBROUTINE ZASYMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y,
     $                   INCY )
*
*  -- PBLAS auxiliary routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      CHARACTER*1        UPLO
      INTEGER            INCX, INCY, LDA, N
      DOUBLE PRECISION   ALPHA, BETA
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   Y( * )
      COMPLEX*16         A( LDA, * ), X( * )
*     ..
*
*  Purpose
*  =======
*
*  ZASYMV performs the following matrix-vector operation
*
*     y := abs( alpha )*abs( A )*abs( x )+ abs( beta*y ),
*
*  where  alpha  and  beta  are real scalars, y is a real vector, x is a
*  vector and A is an n by n symmetric matrix.
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          On entry, UPLO  specifies whether the upper or lower triangu-
*          lar part of the array A is to be referenced as follows:
*
*             UPLO = 'U' or 'u'   Only the upper triangular part of A is
*                                 to be referenced.
*             UPLO = 'L' or 'l'   Only the lower triangular part of A is
*                                 to be referenced.
*
*  N       (input) INTEGER
*          On entry, N specifies the order of the matrix A. N must be at
*          least zero.
*
*  ALPHA   (input) DOUBLE PRECISION
*          On entry, ALPHA specifies the real scalar alpha.
*
*  A       (input) COMPLEX*16 array
*          On entry,  A  is an array of dimension (LDA,N).  Before entry
*          with UPLO = 'U' or 'u', the leading n by n part of the  array
*          A must contain the upper triangular part of the symmetric ma-
*          trix and the strictly lower triangular part of A is not refe-
*          renced.  When  UPLO = 'L' or 'l',  the leading n by n part of
*          the array  A  must  contain  the lower triangular part of the
*          symmetric matrix and the strictly upper trapezoidal part of A
*          is not referenced.
*
*  LDA     (input) INTEGER
*          On entry, LDA specifies the leading dimension of the array A.
*          LDA must be at least max( 1, N ).
*
*  X       (input) COMPLEX*16 array of dimension at least
*          ( 1 + ( n - 1 )*abs( INCX ) ).  Before entry, the incremented
*          array X must contain the vector x.
*
*  INCX    (input) INTEGER
*          On entry, INCX specifies the increment for the elements of X.
*          INCX must not be zero.
*
*  BETA    (input) DOUBLE PRECISION
*          On entry,  BETA  specifies the real scalar beta. When BETA is
*          supplied as zero then Y need not be set on input.
*
*  Y       (input/output) DOUBLE PRECISION array of dimension at least
*          ( 1 + ( n - 1 )*abs( INCY ) ).  Before  entry with  BETA non-
*          zero, the  incremented array  Y must contain the vector y. On
*          exit, the  incremented array  Y is overwritten by the updated
*          vector y.
*
*  INCY    (input) INTEGER
*          On entry, INCY specifies the increment for the elements of Y.
*          INCY must not be zero.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, INFO, IX, IY, J, JX, JY, KX, KY
      DOUBLE PRECISION   TALPHA, TEMP0, TEMP1, TEMP2
      COMPLEX*16         ZDUM
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, DIMAG, MAX
*     ..
*     .. Statement Functions ..
      DOUBLE PRECISION   CABS1
      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF     ( .NOT.LSAME( UPLO, 'U' ).AND.
     $         .NOT.LSAME( UPLO, 'L' )      )THEN
         INFO = 1
      ELSE IF( N.LT.0 )THEN
         INFO = 2
      ELSE IF( LDA.LT.MAX( 1, N ) )THEN
         INFO = 5
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 7
      ELSE IF( INCY.EQ.0 )THEN
         INFO = 10
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'ZASYMV', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) )
     $   RETURN
*
*     Set up the start points in  X  and  Y.
*
      IF( INCX.GT.0 ) THEN
         KX = 1
      ELSE
         KX = 1 - ( N - 1 ) * INCX
      END IF
      IF( INCY.GT.0 )THEN
         KY = 1
      ELSE
         KY = 1 - ( N - 1 ) * INCY
      END IF
*
*     Start the operations. In this version the elements of A are
*     accessed sequentially with one pass through the triangular part
*     of A.
*
*     First form  y := abs( beta * y ).
*
      IF( BETA.NE.ONE ) THEN
         IF( INCY.EQ.1 ) THEN
            IF( BETA.EQ.ZERO ) THEN
               DO 10, I = 1, N
                  Y( I ) = ZERO
   10          CONTINUE
            ELSE
               DO 20, I = 1, N
                  Y( I ) = ABS( BETA * Y( I ) )
   20          CONTINUE
            END IF
         ELSE
            IY = KY
            IF( BETA.EQ.ZERO ) THEN
               DO 30, I = 1, N
                  Y( IY ) = ZERO
                  IY      = IY   + INCY
   30          CONTINUE
            ELSE
               DO 40, I = 1, N
                  Y( IY ) = ABS( BETA * Y( IY ) )
                  IY      = IY           + INCY
   40          CONTINUE
            END IF
         END IF
      END IF
*
      IF( ALPHA.EQ.ZERO )
     $   RETURN
*
      TALPHA = ABS( ALPHA )
*
      IF( LSAME( UPLO, 'U' ) ) THEN
*
*        Form  y  when A is stored in upper triangle.
*
         IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) ) THEN
            DO 60, J = 1, N
               TEMP1 = TALPHA * CABS1( X( J ) )
               TEMP2 = ZERO
               DO 50, I = 1, J - 1
                  TEMP0  = CABS1( A( I, J ) )
                  Y( I ) = Y( I ) + TEMP1 * TEMP0
                  TEMP2  = TEMP2  + TEMP0 * CABS1( X( I ) )
   50          CONTINUE
               Y( J ) = Y( J ) + TEMP1 * CABS1( A( J, J ) ) +
     $                  ALPHA * TEMP2
*
   60       CONTINUE
*
         ELSE
*
            JX = KX
            JY = KY
*
            DO 80, J = 1, N
               TEMP1 = TALPHA * CABS1( X( JX ) )
               TEMP2 = ZERO
               IX    = KX
               IY    = KY
*
               DO 70, I = 1, J - 1
                  TEMP0   = CABS1( A( I, J ) )
                  Y( IY ) = Y( IY ) + TEMP1 * TEMP0
                  TEMP2   = TEMP2   + TEMP0 * CABS1( X( IX ) )
                  IX      = IX      + INCX
                  IY      = IY      + INCY
   70          CONTINUE
               Y( JY ) = Y( JY ) + TEMP1 * CABS1( A( J, J ) ) +
     $                   ALPHA * TEMP2
               JX      = JX      + INCX
               JY      = JY      + INCY
*
   80       CONTINUE
*
         END IF
*
      ELSE
*
*        Form  y  when A is stored in lower triangle.
*
         IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) ) THEN
*
            DO 100, J = 1, N
*
               TEMP1 = TALPHA * CABS1( X( J ) )
               TEMP2  = ZERO
               Y( J ) = Y( J ) + TEMP1 * CABS1( A( J, J ) )
*
               DO 90, I = J + 1, N
                  TEMP0  = CABS1( A( I, J ) )
                  Y( I ) = Y( I ) + TEMP1 * TEMP0
                  TEMP2  = TEMP2  + TEMP0 * CABS1( X( I ) )
*
   90          CONTINUE
*
               Y( J ) = Y( J ) + ALPHA * TEMP2
*
  100       CONTINUE
*
         ELSE
*
            JX = KX
            JY = KY
*
            DO 120, J = 1, N
               TEMP1 = TALPHA * CABS1( X( JX ) )
               TEMP2   = ZERO
               Y( JY ) = Y( JY ) + TEMP1 * CABS1( A( J, J ) )
               IX      = JX
               IY      = JY
*
               DO 110, I = J + 1, N
*
                  IX      = IX      + INCX
                  IY      = IY      + INCY
                  TEMP0   = CABS1( A( I, J ) )
                  Y( IY ) = Y( IY ) + TEMP1 * TEMP0
                  TEMP2   = TEMP2   + TEMP0 * CABS1( X( IX ) )
*
  110          CONTINUE
*
               Y( JY ) = Y( JY ) + ALPHA * TEMP2
               JX      = JX      + INCX
               JY      = JY      + INCY
*
  120       CONTINUE
*
         END IF
*
      END IF
*
      RETURN
*
*     End of ZASYMV
*
      END


! example.f90
program Example50
    implicit none
    character(len=*), parameter :: OUT_FILE = 'data.txt'   ! Output file.
    character(len=*), parameter :: PLT_FILE = 'plot.plt'   ! Gnuplot file.
    integer,          parameter :: N        = 10           ! Number of values.

    integer            :: i, fu
    real, dimension(N) :: x, y

    x(1) = 0.0
    y(1) = 0.0

    do i = 2, N
        x(i) = 0.1 * i
        y(i) = x(i)**2
    end do

    open (action='write', file=OUT_FILE, newunit=fu, status='replace')

    do i = 1, N
        write (fu, *) x(i), y(i)
    end do

    close (fu)

    call execute_command_line('gnuplot -p ' // PLT_FILE)
end program Example50


!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!                          Futility Development Group                          !
!                             All rights reserved.                             !
!                                                                              !
! Futility is a jointly-maintained, open-source project between the University !
! of Michigan and Oak Ridge National Laboratory.  The copyright and license    !
! can be found in LICENSE.txt in the head directory of this repository.        !
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
PROGRAM testSorting
#include "UnitTest.h"
USE UnitTest
USE IntrType
USE Strings
USE Sorting

IMPLICIT NONE
!
!Check the timer resolution
CREATE_TEST('SORTING')
!
REGISTER_SUBTEST('sort Integer',testIntSort)
REGISTER_SUBTEST('sort Integer 2D',testInt2DSort)
REGISTER_SUBTEST('sort Real',testRealSort)
REGISTER_SUBTEST('sort Strings',testStringSort)

REGISTER_SUBTEST('bubble sort',testBubbleSort)
REGISTER_SUBTEST('insertion sort',testInsertSort)

REGISTER_SUBTEST('Speed Test - sort int',testSpeedInt)
REGISTER_SUBTEST('Speed Test - sort real',testSpeedReal)

REGISTER_SUBTEST('Sort Long-Key Int-Val', testKeySort)
FINALIZE_TEST()
!
!
!===============================================================================
CONTAINS
!
!-------------------------------------------------------------------------------
SUBROUTINE testSpeedInt()
  USE Times
  USE StochasticSampling
  INTEGER(SIK),ALLOCATABLE :: A(:)
  INTEGER(SIK) :: n,i,j
  LOGICAL(SBK) :: bool
  TYPE(TimerType) :: testTimer
  TYPE(StochasticSamplingType) :: myRNG

  CALL myRNG%init(RNG_LEcuyer2)
  DO j=1,7
    n=10**j
    ALLOCATE(A(n))
    DO i=1,n
      A(i)=INT(myRNG%rng()*REAL(n*100),SIK)
    ENDDO

    CALL testTimer%tic()
    CALL sort(A)
    CALL testTimer%toc()
    bool=.TRUE.
    DO i=1,n-1
      IF (A(i)>A(i+1)) THEN
        bool=.FALSE.
        EXIT
      ENDIF
    ENDDO
    ASSERT(bool,"qsort speed test - int")

    WRITE(*,*) n, testTimer%elapsedtime
    DEALLOCATE(A)
  ENDDO
  CALL myRNG%clear()
ENDSUBROUTINE testSpeedInt
!
!-------------------------------------------------------------------------------
SUBROUTINE testSpeedReal()
  USE Times
  USE StochasticSampling
  REAL(SRK),ALLOCATABLE :: A(:)
  INTEGER(SIK) :: n,i,j
  LOGICAL(SBK) :: bool
  TYPE(TimerType) :: testTimer
  TYPE(StochasticSamplingType) :: myRNG

  CALL myRNG%init(RNG_LEcuyer2)
  DO j=1,7
    n=10**j
    ALLOCATE(A(n))
    DO i=1,n
      A(i)=myRNG%rng()*REAL(n*100,SRK)
    ENDDO

    CALL testTimer%tic()
    CALL sort(A)
    CALL testTimer%toc()
    bool=.TRUE.
    DO i=1,n-1
      IF (A(i)>A(i+1)) THEN
        bool=.FALSE.
        EXIT
      ENDIF
    ENDDO
    ASSERT(bool,"qsort speed test - real")

    WRITE(*,*) n, testTimer%elapsedtime
    DEALLOCATE(A)
  ENDDO
  CALL myRNG%clear()
ENDSUBROUTINE testSpeedReal
!
!-------------------------------------------------------------------------------
SUBROUTINE testBubbleSort()
  LOGICAL(SBK) :: bool
  INTEGER(SIK) :: tmpintarray(10),tmpint1a(10)
  REAL(SRK) :: tmprealarray(10),tmpreal1a(10)
  TYPE(StringType) :: tmpstrarray(10)

  !Real sorting
  COMPONENT_TEST('Sort 1-D Real array')

  tmprealarray(1)=100.0_SRK
  tmprealarray(2)=-5.0_SRK
  tmprealarray(3)=60.0_SRK
  tmprealarray(4)=10.0_SRK
  tmprealarray(5)=45.0_SRK
  tmprealarray(6)=-10.0_SRK
  tmprealarray(7)=20.0_SRK
  tmprealarray(8)=5.0_SRK
  tmprealarray(9)=-30.0_SRK
  tmprealarray(10)=20.0_SRK

  CALL bubble_sort(tmprealarray)

  bool=ALL(tmprealarray .APPROXEQ. (/-30.0_SRK,-10.0_SRK,-5.0_SRK,5.0_SRK,10.0_SRK, &
      20.0_SRK,20.0_SRK,45.0_SRK,60.0_SRK,100.0_SRK/))
  ASSERT(bool,'1-D real array')

  COMPONENT_TEST('Sort 1-D Real + 1-D Real array')

  tmprealarray(1)=100.0_SRK
  tmprealarray(2)=-5.0_SRK
  tmprealarray(3)=60.0_SRK
  tmprealarray(4)=10.0_SRK
  tmprealarray(5)=45.0_SRK
  tmprealarray(6)=-10.0_SRK
  tmprealarray(7)=20.0_SRK
  tmprealarray(8)=5.0_SRK
  tmprealarray(9)=-30.0_SRK
  tmprealarray(10)=20.0_SRK
  tmpreal1a(1)=10.0_SRK
  tmpreal1a(2)=1.0_SRK
  tmpreal1a(3)=15.0_SRK
  tmpreal1a(4)=-5.0_SRK
  tmpreal1a(5)=-12.0_SRK
  tmpreal1a(6)=0.0_SRK
  tmpreal1a(7)=100.0_SRK
  tmpreal1a(8)=45.0_SRK
  tmpreal1a(9)=3.0_SRK
  tmpreal1a(10)=75.0_SRK

  CALL bubble_sort(tmprealarray,tmpreal1a)

  bool=ALL(tmprealarray .APPROXEQ. (/-30.0_SRK,-10.0_SRK,-5.0_SRK,5.0_SRK,10.0_SRK, &
      20.0_SRK,20.0_SRK,45.0_SRK,60.0_SRK,100.0_SRK/))
  ASSERT(bool,'1-D real array')

  bool=ALL(tmpreal1a .APPROXEQ. (/3.0_SRK,0.0_SRK,1.0_SRK,45.0_SRK,-5.0_SRK, &
      100.0_SRK,75.0_SRK,-12.0_SRK,15.0_SRK,10.0_SRK/))
  ASSERT(bool,'1-D real array')

  !Reverse the argument order for a new result
  tmprealarray(1)=100.0_SRK
  tmprealarray(2)=-5.0_SRK
  tmprealarray(3)=60.0_SRK
  tmprealarray(4)=10.0_SRK
  tmprealarray(5)=45.0_SRK
  tmprealarray(6)=-10.0_SRK
  tmprealarray(7)=20.0_SRK
  tmprealarray(8)=5.0_SRK
  tmprealarray(9)=-30.0_SRK
  tmprealarray(10)=20.0_SRK
  tmpreal1a(1)=10.0_SRK
  tmpreal1a(2)=1.0_SRK
  tmpreal1a(3)=15.0_SRK
  tmpreal1a(4)=-5.0_SRK
  tmpreal1a(5)=-12.0_SRK
  tmpreal1a(6)=0.0_SRK
  tmpreal1a(7)=100.0_SRK
  tmpreal1a(8)=45.0_SRK
  tmpreal1a(9)=3.0_SRK
  tmpreal1a(10)=75.0_SRK

  CALL bubble_sort(tmpreal1a,tmprealarray)

  bool=ALL(tmpreal1a .APPROXEQ. (/-12.0_SRK,-5.0_SRK,0.0_SRK,1.0_SRK,3.0_SRK, &
      10.0_SRK,15.0_SRK,45.0_SRK,75.0_SRK,100.0_SRK/))
  ASSERT(bool,'1-D real array')

  bool=ALL(tmprealarray .APPROXEQ. (/45.0_SRK,10.0_SRK,-10.0_SRK,-5.0_SRK,-30.0_SRK, &
      100.0_SRK,60.0_SRK,5.0_SRK,20.0_SRK,20.0_SRK/))
  ASSERT(bool,'1-D real array')

  COMPONENT_TEST('Sort 1-D Real + 1-D Int array')

  tmprealarray(1)=100.0_SRK
  tmprealarray(2)=-5.0_SRK
  tmprealarray(3)=60.0_SRK
  tmprealarray(4)=10.0_SRK
  tmprealarray(5)=45.0_SRK
  tmprealarray(6)=-10.0_SRK
  tmprealarray(7)=20.0_SRK
  tmprealarray(8)=5.0_SRK
  tmprealarray(9)=-30.0_SRK
  tmprealarray(10)=20.0_SRK
  tmpint1a(1)=10
  tmpint1a(2)=1
  tmpint1a(3)=15
  tmpint1a(4)=-5
  tmpint1a(5)=-12
  tmpint1a(6)=0
  tmpint1a(7)=100
  tmpint1a(8)=45
  tmpint1a(9)=3
  tmpint1a(10)=75

  CALL bubble_sort(tmprealarray,tmpint1a,.TRUE.)

  bool=ALL(tmprealarray .APPROXEQ. (/-30.0_SRK,-10.0_SRK,-5.0_SRK,5.0_SRK,10.0_SRK, &
      20.0_SRK,20.0_SRK,45.0_SRK,60.0_SRK,100.0_SRK/))
  ASSERT(bool,'1-D real array')

  bool=ALL(tmpint1a == (/3,0,1,45,-5,100,75,-12,15,10/))
  ASSERT(bool,'1-D int array')

  COMPONENT_TEST('Sort 1-D Real + 1-D String array')

  tmpreal1a(1)=9.0_SRK
  tmpreal1a(2)=3.0_SRK
  tmpreal1a(3)=5.0_SRK
  tmpreal1a(4)=0.0_SRK
  tmpreal1a(5)=4.0_SRK
  tmpreal1a(6)=1.0_SRK
  tmpreal1a(7)=2.0_SRK
  tmpreal1a(8)=8.0_SRK
  tmpreal1a(9)=7.0_SRK
  tmpreal1a(10)=6.0_SRK
  tmpstrarray(1)='g'
  tmpstrarray(2)='!'
  tmpstrarray(3)='and'
  tmpstrarray(4)='or'
  tmpstrarray(5)='da'
  tmpstrarray(6)='yes'
  tmpstrarray(7)='si'
  tmpstrarray(8)='oui'
  tmpstrarray(9)='string'
  tmpstrarray(10)=''

  CALL bubble_sort(tmpreal1a,tmpstrarray)

  bool=ALL(tmpreal1a == (/0.0_SRK,1.0_SRK,2.0_SRK,3.0_SRK,4.0_SRK,5.0_SRK,6.0_SRK,7.0_SRK,8.0_SRK,9.0_SRK/))
  ASSERT(bool,'1-D real array')

  ASSERT_EQ(CHAR(tmpstrarray(1)),'or','1-D string array 1')
  ASSERT_EQ(CHAR(tmpstrarray(2)),'yes','1-D string array 1')
  ASSERT_EQ(CHAR(tmpstrarray(3)),'si','1-D string array 1')
  ASSERT_EQ(CHAR(tmpstrarray(4)),'!','1-D string array 1')
  ASSERT_EQ(CHAR(tmpstrarray(5)),'da','1-D string array 1')
  ASSERT_EQ(CHAR(tmpstrarray(6)),'and','1-D string array 1')
  ASSERT_EQ(CHAR(tmpstrarray(7)),'','1-D string array 1')
  ASSERT_EQ(CHAR(tmpstrarray(8)),'string','1-D string array 1')
  ASSERT_EQ(CHAR(tmpstrarray(9)),'oui','1-D string array 1')
  ASSERT_EQ(CHAR(tmpstrarray(10)), 'g','1-D string array 1')

  !Integer sorting
  COMPONENT_TEST('Sort 1-D Int array')
  tmpintarray(1)=-5
  tmpintarray(2)=100
  tmpintarray(3)=60
  tmpintarray(4)=10
  tmpintarray(5)=45
  tmpintarray(6)=-10
  tmpintarray(7)=20
  tmpintarray(8)=5
  tmpintarray(9)=-30
  tmpintarray(10)=20

  CALL bubble_sort(tmpintarray)

  bool=ALL(tmpintarray == (/-30,-10,-5,5,10,20,20,45,60,100/))
  ASSERT(bool,'1-D integer array')

  COMPONENT_TEST('Sort 1-D Int + 1-D Real array')

  tmpintarray(1)=-5
  tmpintarray(2)=100
  tmpintarray(3)=60
  tmpintarray(4)=10
  tmpintarray(5)=45
  tmpintarray(6)=-10
  tmpintarray(7)=20
  tmpintarray(8)=5
  tmpintarray(9)=-30
  tmpintarray(10)=20
  tmprealarray(1)=100.0_SRK
  tmprealarray(2)=-5.0_SRK
  tmprealarray(3)=60.0_SRK
  tmprealarray(4)=10.0_SRK
  tmprealarray(5)=45.0_SRK
  tmprealarray(6)=-10.0_SRK
  tmprealarray(7)=20.0_SRK
  tmprealarray(8)=5.0_SRK
  tmprealarray(9)=-30.0_SRK
  tmprealarray(10)=20.0_SRK

  CALL bubble_sort(tmprealarray,tmpintarray,.FALSE.)

  bool=ALL(tmpintarray == (/-30,-10,-5,5,10,20,20,45,60,100/))
  ASSERT(bool,'1-D integer array')

  bool=ALL(tmprealarray .APPROXEQA. (/-30.0_SRK,-10.0_SRK,100.0_SRK,5.0_SRK, &
      10.0_SRK,20.0_SRK,20.0_SRK,45.0_SRK,60.0_SRK,-5.0_SRK/))
  ASSERT(bool,'1-D real array')

  COMPONENT_TEST('Sort 1-D Int + 1-D Int array')
  tmpintarray(1)=-5
  tmpintarray(2)=100
  tmpintarray(3)=60
  tmpintarray(4)=10
  tmpintarray(5)=45
  tmpintarray(6)=-10
  tmpintarray(7)=20
  tmpintarray(8)=5
  tmpintarray(9)=-30
  tmpintarray(10)=20
  tmpint1a(1)=5
  tmpint1a(2)=8
  tmpint1a(3)=6
  tmpint1a(4)=2
  tmpint1a(5)=0
  tmpint1a(6)=4
  tmpint1a(7)=9
  tmpint1a(8)=7
  tmpint1a(9)=1
  tmpint1a(10)=3

  CALL bubble_sort(tmpintarray,tmpint1a)

  bool=ALL(tmpintarray == (/-30,-10,-5,5,10,20,20,45,60,100/))
  ASSERT(bool,'1-D integer array')

  bool=ALL(tmpint1a == (/1,4,5,7,2,9,3,0,6,8/))
  ASSERT(bool,'1-D integer array')

  !Reverse the argument order for new results
  tmpintarray(1)=-5
  tmpintarray(2)=100
  tmpintarray(3)=60
  tmpintarray(4)=10
  tmpintarray(5)=45
  tmpintarray(6)=-10
  tmpintarray(7)=20
  tmpintarray(8)=5
  tmpintarray(9)=-30
  tmpintarray(10)=20
  tmpint1a(1)=5
  tmpint1a(2)=8
  tmpint1a(3)=6
  tmpint1a(4)=2
  tmpint1a(5)=0
  tmpint1a(6)=4
  tmpint1a(7)=9
  tmpint1a(8)=7
  tmpint1a(9)=1
  tmpint1a(10)=3

  CALL bubble_sort(tmpint1a,tmpintarray)

  bool=ALL(tmpint1a == (/0,1,2,3,4,5,6,7,8,9/))
  ASSERT(bool,'1-D integer array')

  bool=ALL(tmpintarray == (/45,-30,10,20,-10,-5,60,5,100,20/))
  ASSERT(bool,'1-D integer array')

  COMPONENT_TEST('Sort 1-D Int + 1-D String array')

  tmpint1a(1)=5
  tmpint1a(2)=8
  tmpint1a(3)=6
  tmpint1a(4)=2
  tmpint1a(5)=0
  tmpint1a(6)=4
  tmpint1a(7)=9
  tmpint1a(8)=7
  tmpint1a(9)=1
  tmpint1a(10)=3
  tmpstrarray(1)='g'
  tmpstrarray(2)='!'
  tmpstrarray(3)='and'
  tmpstrarray(4)='or'
  tmpstrarray(5)='da'
  tmpstrarray(6)='yes'
  tmpstrarray(7)='si'
  tmpstrarray(8)='oui'
  tmpstrarray(9)='string'
  tmpstrarray(10)=''

  CALL bubble_sort(tmpint1a,tmpstrarray)

  bool=ALL(tmpint1a == (/0,1,2,3,4,5,6,7,8,9/))
  ASSERT(bool,'1-D integer array')

  ASSERT_EQ(CHAR(tmpstrarray(1)),'da','1-D string array 1')
  ASSERT_EQ(CHAR(tmpstrarray(2)),'string','1-D string array 1')
  ASSERT_EQ(CHAR(tmpstrarray(3)),'or','1-D string array 1')
  ASSERT_EQ(CHAR(tmpstrarray(4)),'','1-D string array 1')
  ASSERT_EQ(CHAR(tmpstrarray(5)),'yes','1-D string array 1')
  ASSERT_EQ(CHAR(tmpstrarray(6)),'g','1-D string array 1')
  ASSERT_EQ(CHAR(tmpstrarray(7)),'and','1-D string array 1')
  ASSERT_EQ(CHAR(tmpstrarray(8)),'oui','1-D string array 1')
  ASSERT_EQ(CHAR(tmpstrarray(9)),'!','1-D string array 1')
  ASSERT_EQ(CHAR(tmpstrarray(10)),'si','1-D string array 1')
ENDSUBROUTINE testBubbleSort
!
!-------------------------------------------------------------------------------
SUBROUTINE testInsertSort()
  LOGICAL(SBK) :: bool
  INTEGER(SIK) :: tmpintarray(10)
  REAL(SRK) :: tmprealarray(10)

  tmpintarray(1)=-5
  tmpintarray(2)=100
  tmpintarray(3)=60
  tmpintarray(4)=10
  tmpintarray(5)=45
  tmpintarray(6)=-10
  tmpintarray(7)=20
  tmpintarray(8)=5
  tmpintarray(9)=-30
  tmpintarray(10)=20

  CALL insert_sort(tmpintarray)

  bool=ALL(tmpintarray == (/-30,-10,-5,5,10,20,20,45,60,100/))
  ASSERT(bool,'1-D integer array')

  tmprealarray(1)=100.0_SRK
  tmprealarray(2)=-5.0_SRK
  tmprealarray(3)=60.0_SRK
  tmprealarray(4)=10.0_SRK
  tmprealarray(5)=45.0_SRK
  tmprealarray(6)=-10.0_SRK
  tmprealarray(7)=20.0_SRK
  tmprealarray(8)=5.0_SRK
  tmprealarray(9)=-30.0_SRK
  tmprealarray(10)=20.0_SRK

  CALL insert_sort(tmprealarray)

  bool=ALL(tmprealarray .APPROXEQ. (/-30.0_SRK,-10.0_SRK,-5.0_SRK,5.0_SRK,10.0_SRK, &
      20.0_SRK,20.0_SRK,45.0_SRK,60.0_SRK,100.0_SRK/))
  ASSERT(bool,'1-D real array')
ENDSUBROUTINE testInsertSort
!
!-------------------------------------------------------------------------------
SUBROUTINE testIntSort()
  LOGICAL(SBK) :: bool
  INTEGER(SIK) :: tmpintarray(10)

  tmpintarray(1)=-5
  tmpintarray(2)=100
  tmpintarray(3)=60
  tmpintarray(4)=10
  tmpintarray(5)=45
  tmpintarray(6)=-10
  tmpintarray(7)=20
  tmpintarray(8)=5
  tmpintarray(9)=-30
  tmpintarray(10)=20

  CALL sort(tmpintarray)

  bool=ALL(tmpintarray == (/-30,-10,-5,5,10,20,20,45,60,100/))
  ASSERT(bool,'1-D integer array qsort')
ENDSUBROUTINE testIntSort
!
!-------------------------------------------------------------------------------
SUBROUTINE testInt2DSort()
  LOGICAL(SBK) :: bool
  INTEGER(SIK) :: tmpintarray2(5,5)

  tmpintarray2(1,1)=-5
  tmpintarray2(2,1)=100
  tmpintarray2(3,1)=60
  tmpintarray2(4,1)=10
  tmpintarray2(5,1)=45
  tmpintarray2(1,2)=-10
  tmpintarray2(2,2)=20
  tmpintarray2(3,2)=5
  tmpintarray2(4,2)=-30
  tmpintarray2(5,2)=20
  tmpintarray2(1,3)=0
  tmpintarray2(2,3)=-20
  tmpintarray2(3,3)=-15
  tmpintarray2(4,3)=30
  tmpintarray2(5,3)=21
  tmpintarray2(1,4)=4
  tmpintarray2(2,4)=-16
  tmpintarray2(3,4)=-50
  tmpintarray2(4,4)=-30
  tmpintarray2(5,4)=50
  tmpintarray2(1,5)=53
  tmpintarray2(2,5)=77
  tmpintarray2(3,5)=88
  tmpintarray2(4,5)=99
  tmpintarray2(5,5)=35

  CALL sort(tmpintarray2)
  bool=ALL(tmpintarray2 == RESHAPE((/-50,-30,-30,-20,-16,-15,-10,-5,0,4,5,10,20,20,21,30,35,45,50,53,60,77,88,99,100/),(/5,5/)))
  ASSERT(bool,'2-D array sort')
ENDSUBROUTINE testInt2DSort
!
!-------------------------------------------------------------------------------
SUBROUTINE testRealSort()
  LOGICAL(SBK) :: bool
  REAL(SRK) :: tmprealarray(10)

  tmprealarray(1)=100.0_SRK
  tmprealarray(2)=-5.0_SRK
  tmprealarray(3)=60.0_SRK
  tmprealarray(4)=10.0_SRK
  tmprealarray(5)=45.0_SRK
  tmprealarray(6)=-10.0_SRK
  tmprealarray(7)=20.0_SRK
  tmprealarray(8)=5.0_SRK
  tmprealarray(9)=-30.0_SRK
  tmprealarray(10)=20.0_SRK

  CALL sort(tmprealarray)

  bool=ALL(tmprealarray .APPROXEQ. (/-30.0_SRK,-10.0_SRK,-5.0_SRK,5.0_SRK,10.0_SRK, &
    20.0_SRK,20.0_SRK,45.0_SRK,60.0_SRK,100.0_SRK/))
  ASSERT(bool,'1-D real array qsort')
ENDSUBROUTINE testRealSort
!
!-------------------------------------------------------------------------------
SUBROUTINE testStringSort()
  TYPE(StringType),ALLOCATABLE :: testStr(:)

  COMPONENT_TEST('Empty')
  ALLOCATE(testStr(0))
  CALL sort(testStr)
  ASSERT_EQ(SIZE(testStr),0,'size')
  DEALLOCATE(testStr)

  COMPONENT_TEST('length 1')
  ALLOCATE(testStr(1))
  testStr(1)='test'
  CALL sort(testStr)
  ASSERT_EQ(SIZE(testStr),1,'size')
  ASSERT_EQ(CHAR(testStr(1)),'test','string(1)')
  DEALLOCATE(testStr)

  COMPONENT_TEST('already sorted')
  ALLOCATE(testStr(3))
  testStr(1)='test a'
  testStr(2)='test b'
  testStr(3)='tests'
  CALL sort(testStr)
  ASSERT_EQ(SIZE(testStr),3,'size')
  ASSERT_EQ(CHAR(testStr(1)),'test a','string(1)')
  ASSERT_EQ(CHAR(testStr(2)),'test b','string(2)')
  ASSERT_EQ(CHAR(testStr(3)),'tests','string(3)')
  DEALLOCATE(testStr)

  COMPONENT_TEST('simple')
  ALLOCATE(testStr(3))
  testStr(1)='test b'
  testStr(2)='test a'
  testStr(3)='tests'
  CALL sort(testStr)
  ASSERT_EQ(SIZE(testStr),3,'size')
  ASSERT_EQ(CHAR(testStr(1)),'test a','string(1)')
  ASSERT_EQ(CHAR(testStr(2)),'test b','string(2)')
  ASSERT_EQ(CHAR(testStr(3)),'tests','string(3)')
  DEALLOCATE(testStr)

  COMPONENT_TEST('backwards')
  ALLOCATE(testStr(3))
  testStr(1)='tests'
  testStr(2)='test b'
  testStr(3)='test a'
  CALL sort(testStr)
  ASSERT_EQ(SIZE(testStr),3,'size')
  ASSERT_EQ(CHAR(testStr(1)),'test a','string(1)')
  ASSERT_EQ(CHAR(testStr(2)),'test b','string(2)')
  ASSERT_EQ(CHAR(testStr(3)),'tests','string(3)')
  DEALLOCATE(testStr)

  COMPONENT_TEST('all the same')
  ALLOCATE(testStr(3))
  testStr(1)='test'
  testStr(2)='test'
  testStr(3)='test'
  CALL sort(testStr)
  ASSERT_EQ(SIZE(testStr),3,'size')
  ASSERT_EQ(CHAR(testStr(1)),'test','string(1)')
  ASSERT_EQ(CHAR(testStr(2)),'test','string(2)')
  ASSERT_EQ(CHAR(testStr(3)),'test','string(3)')
  DEALLOCATE(testStr)

  COMPONENT_TEST('some the same')
  ALLOCATE(testStr(3))
  testStr(1)='test a'
  testStr(3)='tests'
  testStr(2)='test a'
  CALL sort(testStr)
  ASSERT_EQ(SIZE(testStr),3,'size')
  ASSERT_EQ(CHAR(testStr(1)),'test a','string(1)')
  ASSERT_EQ(CHAR(testStr(2)),'test a','string(2)')
  ASSERT_EQ(CHAR(testStr(3)),'tests','string(3)')
  DEALLOCATE(testStr)

  COMPONENT_TEST('has empty string')
  ALLOCATE(testStr(3))
  testStr(1)='test a'
  testStr(2)='test b'
  testStr(3)=''
  CALL sort(testStr)
  ASSERT_EQ(SIZE(testStr),3,'size')
  ASSERT_EQ(CHAR(testStr(1)),'','string(1)')
  ASSERT_EQ(CHAR(testStr(2)),'test a','string(2)')
  ASSERT_EQ(CHAR(testStr(3)),'test b','string(3)')
  DEALLOCATE(testStr)

ENDSUBROUTINE testStringSort
!
!-------------------------------------------------------------------------------
SUBROUTINE testKeySort()
  LOGICAL(SBK) :: bool
  INTEGER(SIK) :: idxOrig(16), i,iVal,jVal
  INTEGER(SLK) :: diagRank(16)

  ! 1  2  3  4
  ! 5  6  7  8
  ! 9  10 11 12
  ! 13 14 15 16
  DO i=1,16
    idxOrig(i) = i
    iVal = (i-1)/4+1
    jVal = MOD(i-1,4)+1
    diagRank(i) = INT(jVal - 1 + ((3-iVal+jVal)*(4-iVal+jVal))/2,8)
  ENDDO

  CALL sort(diagRank, idxOrig)

  bool=ALL(idxOrig .EQ. (/13,9,14,5,10,15,1,6,11,16,2,7,12,3,8,4/))
  ASSERT(bool,'Diagonal Matrix Sort')

END SUBROUTINE testKeySort
!
ENDPROGRAM testSorting


module Simulation

    use Input
    use Output
    use precision

    type KTzParam
        real(kr8) :: K, T, d, l, xR, H, Z
    end type KTzParam

    abstract interface
        function KTzIterator(neuPar, xAnt)
            import KTzParam, kr8
            real(kr8) :: xAnt(3)
            type(KTzParam) :: neuPar
            real(kr8), dimension(3) :: KTzIterator
        end function KTzIterator
    end interface

    private :: SimulaPara_xR_T, KTzLogIter, KTzTanhIter, K2TzIter, KTzIterator
    private :: unique, findISI, logisticFunc, GetKTzParams, GetKTzParamValue
    public :: Simula
contains

    subroutine Simula(parBData, parAData, isiData, intData)
        use Input
        use Output
        implicit none
        !external AbreArquivo
        real(kr8) :: dparB, dparA, parA, parB
        real(kr8), allocatable, intent(inout) :: parBData(:), parAData(:),&
                                                 isiData(:), intData(:)
        real(kr8), allocatable :: isi(:), parBDataTemp(:), parADataTemp(:)
        real(kr8), allocatable :: isiDataTemp(:), intDataTemp(:), intensity(:)
        character(len=256) :: nomeArqSaida
        integer :: i, j, k, m, n, u
        logical :: isISI
        type(KTzParam) :: neuPar
        procedure(KTzIterator), pointer :: KTzFunc

        isISI = .false.
        if (trim(par%measure) == "ISI") then
            isISI = .true.
        end if

        if (par%model == "L") then
            KTzFunc => KTzLogIter
        else if (par%model == "T") then
            KTzFunc => KTzTanhIter
        else if (par%model == "2") then
            KTzFunc => K2TzIter
        else
            write (*,*) 'ERROR! Unrecognized model'
            stop
        end if
        dparA = 0.0D0
        dparB = 0.0D0
        if (par%nparA > 1) then
            dparA = (par%parA2 - par%parA1) / dble(par%nparA - 1)
        end if
        if (par%nparB > 1) then
            dparB = (par%parB2 - par%parB1) / dble(par%nparB - 1)
        end if

        if (par%writeOnRun) then
            nomeArqSaida = trim(pegaNomeArqSaida())
            u = AbreArquivo("replace", &
                            "write", &
                            trim(trim(pegaStrParamEntrada())// &
                                "# "//trim(par%parB)//"     "//trim(par%parA)//&
                                "     "//trim(par%measure)//&
                                "     intensity"),nomeArqSaida)
            do i = 1, par%nparB
                parB = par%parB1 + dparB * dble(i-1)
                write (*,*) 'Simulando para '//trim(par%parB)//'=',parB
                do j = 1, par%nparA
                    parA = par%parA1 + dparA * dble(j-1)
                    !write (*,*) 'Simulando para '//trim(par%parB)//'=',parB,'; '//trim(par%parA)//'=', parA
                    neuPar = GetKTzParams(parA,parB)
                    if (isISI) then
                        call SimulaPara_xR_T_ISI(neuPar, KTzFunc, isi, intensity)
                    else
                        call SimulaPara_xR_T_AMP(neuPar, KTzFunc, isi, intensity)
                    end if
                    n = size(isi, 1)
                    do k = 1, n
                        write (u, "(4D17.8)") parB, parA, isi(k), intensity(k)
                    end do
                end do
                write (u,*)
                write (u,*)
            end do
            close(unit=u)
            write (*,'(A,A)') 'Arquivo escrito: ', trim(nomeArqSaida)
        else
            m = 10 * par%nparB * par%nparA ! assumindo que ha em torno de, no max, 3 ISI simult por par xR,T
            allocate(parBDataTemp(1:m))
            allocate(parADataTemp(1:m))
            allocate(isiDataTemp(1:m))
            allocate(intDataTemp(1:m))

            m = 0
            do i = 1, par%nparB
                parB = par%parB1 + dparB * dble(i-1)
                write (*,*) 'Simulando para '//trim(par%parB)//'=',parB
                do j = 1, par%nparA
                    parA = par%parA1 + dparA * dble(j-1)
                    !write (*,*) 'Simulando para '//trim(par%parB)//'=',parB,'; '//trim(par%parA)//'=', parA
                    neuPar = GetKTzParams(parA,parB)
                    if (isISI) then
                        call SimulaPara_xR_T_ISI(neuPar, KTzFunc, isi, intensity)
                    else
                        call SimulaPara_xR_T_AMP(neuPar, KTzFunc, isi, intensity)
                    end if
                    n = size(isi, 1)
                    do k = 1, n
                        m = m + 1
                        parBDataTemp(m) = parB
                        parADataTemp(m) = parA
                        isiDataTemp(m) = isi(k)
                        intDataTemp(m) = intensity(k)
                    end do
                end do
            end do

            allocate(parBData(1:m), parAData(1:m), isiData(1:m), intData(1:m))
            parBData = parBDataTemp(1:m)
            parAData = parADataTemp(1:m)
            isiData = isiDataTemp(1:m)
            intData = intDataTemp(1:m)
        end if
    end subroutine Simula

    function GetKTzParams(pA,pB) result (neuPar)
        use Input
        implicit none
        real(kr8) :: pA, pB
        type(KTzParam) :: neuPar
        neuPar%K = GetKTzParamValue("K ",pA,pB)
        neuPar%T = GetKTzParamValue("T ",pA,pB)
        neuPar%d = GetKTzParamValue("d ",pA,pB)
        neuPar%l = GetKTzParamValue("l ",pA,pB)
        neuPar%xR = GetKTzParamValue("xR",pA,pB)
        neuPar%H = GetKTzParamValue("H ",pA,pB)
        neuPar%Z = GetKTzParamValue("Z ",pA,pB)
    end function GetKTzParams

    function GetKTzParamValue(p,pA,pB) result (v)
        use Input
        implicit none
        character(len=2) :: p
        real(kr8) :: pA, pB, v

        if (trim(p) == par%parA) then
            v = pA
        else if (trim(p) == par%parB) then
            v = pB
        else
            if (trim(p) == "K") then
                v = par%K
            else if (trim(p) == "T") then
                v = par%T
            else if (trim(p) == "d") then
                v = par%d
            else if (trim(p) == "l") then
                v = par%l
            else if (trim(p) == "xR") then
                v = par%xR
            else if (trim(p) == "H") then
                v = par%H
            else
                v = par%Z
            end if
        end if
    end function GetKTzParamValue

    subroutine SimulaPara_xR_T_ISI(neuPar, KTzFunc, isi, intensity)
        use Input
        implicit none
        real(kr8), allocatable, intent(inout) :: isi(:), intensity(:)
        real(kr8) :: x(3) ! x(1) = x, x(2) = y, x(3) = z
        !real(kr8), intent(in) :: K, T, d, l, xR, H
        real(kr8), allocatable :: isiData(:)
        real(kr8) :: t1, t2, ts, tsA, xAnt
        integer :: tt, tEff
        integer :: i, k, iplus, crossCounter
        logical :: isFP
        type(KTzParam), intent(in) :: neuPar
        procedure(KTzIterator), pointer, intent(in) :: KTzFunc

        isFP = .false.

        tEff = par%tTotal - par%tTransient

        if (.not.allocated(isiData)) then
            allocate(isiData(1:tEff)) ! alocando tEff valores para os isi
        end if

        !neuPar%K = K
        !neuPar%T = T
        !neuPar%d = d
        !neuPar%l = l
        !neuPar%xR = xR
        !neuPar%H = H

        x = par%x0
        do tt = 1,par%tTransient
            xAnt = x(1)
            x = KTzFunc(neuPar, x)
            if (dabs(x(1) - xAnt) <= 1.0e-8) then
                isFP = .true.
                exit
            end if
        end do
        if (.not.isFP) then
            do while (x(1) > par%xThreshold) ! garantindo que o loop principal começara com x(i)<0
                xAnt = x(1);
                x = KTzFunc(neuPar, x)
                if (dabs(x(1) - xAnt) <= 1.0e-8) then
                    isFP = .true.
                    exit
                end if
            end do
        end if
        t1 = 0
        t2 = 0
        ts = 0
        tsA = 0
        crossCounter = 0
        xAnt = x(1)
        k = 0
        if (.not.isFP) then
            do tt = 2,tEff ! loop principal
                x = KTzFunc(neuPar, x)
                if (dabs(x(1) - xAnt) <= 1.0e-8) then
                    isFP = .true.
                    exit
                end if
                if ((xAnt - par%xThreshold) * (x(1) - par%xThreshold) < 0.0D0) then ! cruzou o eixo x = xThreshold
                    if (modulo(crossCounter,2) == 0) then ! como começou abaixo de x = 0, crossCounter par significa subindo
                        t1 = (dble(tt - 1) + dble(tt)) / 2.0D0
                    else ! crossCounter impar significa descendo
                        t2 = (dble(tt - 1) + dble(tt)) / 2.0D0
                        ts = (t1 + t2) / 2.0D0 ! o instante do disparo eh a media entre tempo subida (t1) e descida (t2)
                        k = k + 1 ! k = qtd de ISI achados
                        isiData(k) = ts - tsA
                        tsA = ts
                    end if
                    crossCounter = crossCounter + 1
                end if
                xAnt = x(1)
            end do
        end if

        if (allocated(isi)) then
            deallocate(isi, intensity)
        end if
        if (isFP.or.(k == 0).or.(k == 1)) then ! nenhum ISI encontrado
            allocate(isi(1:1), intensity(1:1))
            isi(1) = 0.0D0
            intensity(1) = 1.0D0
        else
            call unique(isiData(2:k), isi, intensity)
        end if
    end subroutine  SimulaPara_xR_T_ISI

    subroutine SimulaPara_xR_T_AMP(neuPar, KTzFunc, amp, intensity)
        use Input
        implicit none
        real(kr8), allocatable, intent(inout) :: amp(:), intensity(:)
        real(kr8) :: x(3) ! x(1) = x, x(2) = y, x(3) = z
        !real(kr8), intent(in) :: K, T, d, l, xR, H
        real(kr8) :: xMin, xMax
        integer :: tt, tEff
        type(KTzParam), intent(in) :: neuPar
        procedure(KTzIterator), pointer, intent(in) :: KTzFunc

        if (.not.allocated(amp)) then
            allocate(amp(1:1), intensity(1:1))
        end if

        intensity = 0.0D0

        tEff = par%tTotal - par%tTransient

        !neuPar%K = K
        !neuPar%T = T
        !neuPar%d = d
        !neuPar%l = l
        !neuPar%xR = xR
        !neuPar%H = H

        x = par%x0
        do tt = 1,par%tTransient
            x = KTzFunc(neuPar, x)
        end do
        xMax = - huge(xMax)
        xMin = huge(xMin)
        do tt = 1,tEff ! loop principal
            x = KTzFunc(neuPar, x)
            if (x(1) < xMin) then
                xMin = x(1)
            end if
            if (x(1) > xMax) then
                xMax = x(1)
            end if
        end do
        amp = xMax - xMin
    end subroutine  SimulaPara_xR_T_AMP

    ! intensity eh a qtd de vezes que um valor de x se repete, em relacao ao total de valores de x
    ! tal que sum(intensity) = 1
    subroutine unique(x, xUn, intensity)
        implicit none
        real(kr8), intent(in) :: x(:)
        real(kr8), allocatable, intent(inout) :: xUn(:), intensity(:)
        real(kr8) :: res(size(x,1))
        real(kr8) :: intTemp(size(x,1))
        integer :: k                   ! The number of unique elements
        integer :: i, j

        intTemp = 1.0D0

        k = 1
        res(1) = x(1)
        outer: do i=2,size(x)
            do j=1,k
                if (res(j) == x(i)) then
                    ! Found a match so start looking again
                    intTemp(j) = intTemp(j) + 1.0D0
                    cycle outer
                end if
            end do
            ! No match found so add it to the output
            k = k + 1
            res(k) = x(i)
        end do outer

        allocate(xUn(1:k), intensity(1:k))
        xUn = res(1:k)
        intensity = intTemp(1:k) / dble(size(x,1))
    end subroutine unique

    ! o algoritmo abaixo esta incorporado na rotina
    ! SimulaPara_xR_T e, portanto, nao esta sendo usado
    ! neste programa por enquanto
    subroutine findISI(x, isi)
        real*8, intent(in) :: x(:)
        real*8, allocatable, intent(out) :: isi(:)
        real*8, allocatable :: isiData(:)
        integer :: i, k, iplus, crossCounter
        real*8 :: t1, t2, ts, tsA

        t1 = 0
        t2 = 0
        ts = 0
        tsA = 0
        crossCounter = 0
        n = size(x, 1) - 1
        allocate(isiData(1:n)) ! alocando n valores para os isi
        i = 1
        do while (x(i) > 0.0D0) ! garantindo que o loop principal começara com x(i)<0
            i = i + 1
        end do
        k = 1
        do while (i <= n) ! loop principal
            iplus = i + 1
            if (x(i) * x(iplus) < 0) then ! cruzou o eixo x = 0
                if (modulo(crossCounter,2) == 0) then ! como começou abaixo de x = 0, crossCounter par significa subindo
                    t1 = (dble(i) + dble(iplus)) / 2.0D0
                else ! crossCounter impar significa descendo
                    t2 = (dble(i) + dble(iplus)) / 2.0D0
                    ts = (t1 + t2) / 2.0D0
                    isiData(k) = ts - tsA
                    tsA = ts
                    k = k + 1
                end if
                crossCounter = crossCounter + 1
            end if
            i = i + 1
        end do
        k = k - 1 ! k = total de ISI encontraldos
        allocate(isi(1:(k-1)))
        isi = isiData(2:k)
    end subroutine findISI

    function KTzTanhIter(neuPar, xAnt) result (x)
        implicit none
        real(kr8) :: x(3), xAnt(3)
        type(KTzParam) :: neuPar
        x(2) = xAnt(1)
        x(3) = (1.0D0 - neuPar%d) * xAnt(3) - neuPar%l * (xAnt(1) - neuPar%xR)
        x(1) = dtanh((xAnt(1) - neuPar%K * xAnt(2) + xAnt(3) + neuPar%H) / neuPar%T)
    end function KTzTanhIter

    function KTzLogIter(neuPar, xAnt) result (x)
        implicit none
        real(kr8) :: x(3), xAnt(3)
        type(KTzParam) :: neuPar
        x(2) = xAnt(1)
        x(3) = (1.0D0 - neuPar%d) * xAnt(3) - neuPar%l * (xAnt(1) - neuPar%xR)
        x(1) = logisticFunc((xAnt(1) - neuPar%K * xAnt(2) + xAnt(3) + neuPar%H) / neuPar%T)
    end function KTzLogIter

    function K2TzIter(neuPar, xAnt) result (x)
        implicit none
        real(kr8) :: x(3), xAnt(3)
        type(KTzParam) :: neuPar
        x(2) = dtanh( (xAnt(1) + neuPar%H) / neuPar%T )
        x(3) = (1.0D0 - neuPar%d) * xAnt(3) - neuPar%l * (xAnt(1) - neuPar%xR)
        x(1) = dtanh((xAnt(1) - neuPar%K * xAnt(2) + xAnt(3) + neuPar%Z) / neuPar%T)
    end function K2TzIter

    function logisticFunc(x) result(y)
        implicit none
        real(kr8) :: x, y
        y = x / (1.0D0 + dabs(x))
    end function logisticFunc

end module Simulation


program main
    use const
    use test
    use file
    use input
    implicit none

    real(rk) :: time_start, time_stop, time_total, data(maxarg)
    integer(ik), allocatable :: result(:)
    integer(ik) :: i, n, m, num, step, flag, start
    character(maxlen) :: filename, format

    filename = 'numbers.dat'

    call in(data)

    n = int(data(1), ik)
    step = int(data(2), ik)
    flag = int(data(3), ik)

    allocate(result(n))
    result = 0

    call read_from_file(filename, i, m, flag)

    start = i

    num = 0

    call cpu_time(time_start)

    do while (num < n * step)
        i = i + 1
        if (O(i)) then
            num = num + 1
            if (start /= 1 .and. i /= start) then
                if (mod(num, step) == 0) then
                    result(num / step) = i
                end if
            else if (start == 1) then
                result(num / step) = i
            end if
        end if
    end do

    call cpu_time(time_stop)

    format = '(a, f7.2, a, /)'

    write(6, '()')
    write(6, format) 'CPU time spent during loop: ', time_stop - time_start, ' s'

    time_total = time_stop - time_start

    call cpu_time(time_start)

    call write_to_file(result, n, m, step, filename)

    call cpu_time(time_stop)

    write(6, format) 'CPU time spent during writing: ', time_stop - time_start, ' s'

    time_total = time_total + time_stop - time_start

    write(6, format) 'CPU time spent in total: ', time_total, ' s'
end program main


      program kkrmat_compare
      implicit none
      integer n,n2,i,j,argc
      real*8 er,ei,er2,ei2
      real*8 ar1,ai1,ar2,ai2
      integer ii,jj
      complex*16 a
      character(len=64) :: argv(2)
      real*8 tol,err

      tol=0.001

      argc=command_argument_count()
      if(argc.ne.2) then
        write(*,*) "Expected two arguments: files to compare"
        stop
      end if
      call get_command_argument(1,argv(1))
      call get_command_argument(2,argv(2))

      write(*,*) "Comapring files '",trim(argv(1)),
     &           "' and '",trim(argv(2)),"'"

      open(unit=11,file=trim(argv(1)))
      open(unit=12,file=trim(argv(2)))

      read(11,*) n,er,ei
      read(12,*) n2,er2,ei2

      if(n.ne.n2) then
        write(*,*) "n(",trim(argv(1)),") = ",n," not equal to ",
     &             "n(",trim(argv(2)),") = ",n2
        stop
      end if

      if(er.ne.er2 .or. ei.ne.ei2) then
        write(*,*) "e(",trim(argv(1)),") = (",er,", ",ei,
     &             ") not equal to ",
     &             "e(",trim(argv(2)),") = (",er2,", ",ei2,")"
!       stop
      end if
      write(*,*) "Energy = (",er,", ",ei,")"

!      allocate(a(n,n))

      do i=1,n
        do j=1,n
          read(11,*) ii,jj,ar1,ai1
          read(12,*) ii,jj,ar2,ai2
          a=cmplx(ar1,ai1)-cmplx(ar2,ai2)
          if(abs(a).ne.0.0) then
             err=abs(a)/abs(cmplx(ar1,ai1)+cmplx(ar2,ai2))
             if(err.gt.tol) then
                write(*,*) i,j,ar1,ai1,ar2,ai2
             end if
          end if
       end do
      end do

      end


!!
!! Luke McCulloch
!! solver.f90
!! 8-25-2011
!! Serial Solution Various equations - This will be Inviscid Burgers.
!!
!!   Variable Listing
!! Comp   - Compare Acutal to Computed Solutions
!! Compo  - Old Comparison (used to max Comp as a scalar)
!! diffo  - intial difference between T(i,j)new and T(i,j)old
!! diff   - latest difference between T(i,j)new and T(i,j)old
!! lx     - domain space in x
!! ly     - domain space in y
!! dx     - element size in x
!! dy     - element size in y
!! NI     - # points in x
!! NJ     - # points in y
!! n      - dummy vbl for points (mabye points is more machinery than needed)
!! nipt   - Total number of points on the plate = NI*NJ
!! K      - Iteration counter  ????Never used????
!! i      - ith position in x
!! j      - jth position in y
!! ipt    - dummy points index "the ipt'th position of nipt total"
!! C      - Cnst term in the discrete second differences
!! mn     - max norm of all "diffs"  //T(i,j)-To(i,j)//, and max norm of the solution variance (loosley speaking)
!! ux, uy - Unit vectors
!! X, Y   - Actual Geometry Position maps of i,j (Scaler values)
!! Points - Vector Valued (X(i,j),Y(i,j))  - Again more machinery than needed
!! T      - Temperature at T(i,j) at K iterations - i.e. the solution at the end
!! S      - Given Source F(i,j)->F(x,y)  S(x,y) = xe^y
!! To     - T(i,j) at K-1 iterations ( i.e. before update )
!! Treal  - Mathematical solution to the problem
!! w      - Relaxation factor {: (0,2)  <1 is slower but more convergent.  >1 is faster but less convergent...

PROGRAM solver

  use precise, only : defaultp   ! Module to handle precision
  use GEO                        ! Module to write the Points on the surface
  !!use Source                     ! Module to compute an arbitrary source term.
  use inv                        ! My tri dag inversion module from Spring 2011
  use Swafftridag                ! Swaffs version

  IMPLICIT NONE

  integer, parameter :: WP=defaultp
  real, parameter :: e=2.718281828459045
  INTEGER, DIMENSION(5), PARAMETER :: it1 = (/ 1, 5, 10, 15, 40 /)   ! GNU output times

  integer::count_0, count1, count2, count_rate, count_max, walltime, tstart, tend

  Integer :: NI, i, t, NT, m, mmax
  Real(WP) :: dx, L, dt, Umx
  Real(WP), DIMENSION(2) :: ux           ! Unit Vectors
  REAL(wp), Allocatable, DIMENSION(:) :: X, ratiodtdx  ! X locations
  REAL(wp), Allocatable, DIMENSION(:) :: am, bm, cm ! Diagonal Matrices
  REAL(WP), ALLOCATABLE, DIMENSION(:,:) :: RHS, Delta, U, Uexact, Aplus, Aminus, L1, L2, fplus, fminus, F ! Velocity, scheme components
  REAL(WP), ALLOCATABLE, DIMENSION(:,:) :: Unm

  ! Simple start up message
  WRITE(6,'(A)') 'CFD Burgers Schemes Code'
  Write(6,*)     ' 10-09-2011 Implementation By Luke McCulloch'
  write(6,*) ''
  Write(6,*)     ' Implicit Solver FV Inviscid Burgers Equation in 1D'
  write(6,*) '--------------------------------------------------------'

  Umx=-1.0e10
  dx=0.05
  L=3.
  NI=int(real(L/dx))
  NI=NI+1
  dt = 0.03333333  !!Swaffs Recommendation-may try others to see what it does.
  NT=40

  Allocate( X(NI) )
  Allocate( U(NI,0:NT) )
  Allocate( Uexact(NI,0:NT) )
  Allocate( am(NI-3) )
  Allocate( bm(NI-2) )
  Allocate( cm(NI-3) )

  Allocate( L1(NI,0:NT) )
  Allocate( L2(NI,0:NT) )
  Allocate( Aplus(NI,0:NT) )
  Allocate( Aminus(NI,0:NT) )

  Allocate( Fplus(NI-2,0:NT) )
  Allocate( Fminus(NI-2,0:NT) )
  Allocate( F(NI-2,0:NT) )

  Allocate( Delta(NI-2,0:NT) )
  Allocate( RHS(NI,0:NT) )
  Allocate( Unm(NI,0:NT) )

  write(*,*) 'memory allocation complete'

  write(*,*) 'compute points on a line'
  Call D1(NI, dx, X )   ! Subroutine to compute the vector of Points.

  !Check Points - Comment this in the full Version
!  Write(6,'(AA)') 'Points'

!!$  do i=1,NI
!!$     !write(6,'(2D16.8)') X(i)
!!$     write(*,*) 'I, X(i)', i, X(i)
!!$  end do
!!$  Write(6,*) ''
  !Get rid of this in the full Version, obv

!  write(6,*) NI

  write(*,*) 'establish B.C.s'
  !Establish the B.C.'s-------------------------------------------------
  Do i=1,NI
     U(i,0)=0.0  !Going to need to specifdy U(0.,t)=0.0, U(3.,t)=0.0
     !Delta(i,0)=0.0
  End Do
  !Do i=1,NI
     !Going to need to specifdy U(0.,t)=0.0, U(3.,t)=0.0
   !  Delta(i,0)=0.0
  !End Do

  write(*,*) '----------------Boundary Conditions--------------'
  write(*,*) '                  0. <= x <= 1.0'
  count1=1
  count2=int(real(1.0/dx))+1
  Do i=count1,count2
     u(i,0)=1.5
     Unm(i,0)=1.5
     write(*,*) 'i, x(0), u(x,0)', i, X(i), U(i,0)
  End do
  write(*,*) '                  1.0 < x <= 3.0'
  count1=int(real(1.0/dx))+2
  count2=int(real(3.0/dx))+1
  Do i=count1,count2
     u(i,0)=0.5
     Unm(i,0)=0.5
     write(*,*) 'i, x(0), u(x,0)', i, X(i), U(i,0)
  End do
  write(*,*) ''

  !End of the B.C. portion------------------------------------------------

  !!c=1.0  !! Non constant

  !! Subroutine to establish the initial equation terms
!!$  do i=1, NI
!!$  ratiodtdx= 0.8/max(Umx, U(i,:))
!!$  end do
!!$  write(*,*) 'ratiodtdx', ratiodtdx
 !! Umx=1.5

!!--------------Simple Upwind Difference (backward space difference) - Working
!!$  Write (*,*) '------------------Begin Simple Upwind Difference------------------------'
!!$  Do t=0,NT
!!$     Write(*,*) 'Begin Time step t =', t
!!$     do i=2,NI
!!$        U(1,t+1)=U(1,t)
!!$        U(i,t+1)=U(i,t)-0.5*dt*((U(i,t)**2.)-(U(i-1,t)**2.))/dx  !! Watch your signs
!!$     write(*,*) '   u(x,t)   ',i, x(i), U(i,t+1)
!!$     end do
!!$     write(*,*) 'End timestep t'
!!$  end do

!!--------------Lax-Friedrichs (Central Space Difference)

!!$  Write (*,*) '------------------Begin Lax-Friedrichs Method---------------------------'
!!$  Do t=1,NT
!!$     Write(*,*) 'Begin Time step t'
!!$     do i=2,NI-1
!!$        U(1,t)=U(1,t-1)
!!$        U(NI,t)=U(NI,t-1)
!!$        U(i,t) =0.5*(U(i+1,t-1)+U(i-1,t-1))-0.25*(dt/dx)*((U(i+1,t-1))**2.-(U(i-1,t-1))**2.)
!!$        write(*,*) ' i, X(i)   u(x,t)   ', i, X(i), U(i,t)
!!$     end do
!!$     write(*,*) 'End timestep t'
!!$  end do

!!--------------Lax-Wendroff (Central Space Difference)

!!$  Write (*,*) '------------------Begin Lax-Wendroff Method---------------------------'
!!$  Do t=1,NT
!!$     Write(*,*) 'Begin Time step t'
!!$     do i=2,NI-1
!!$        U(1,t)=U(1,t-1)
!!$        U(NI,t)=U(NI,t-1)
!!$
!!$        L1(i,t-1)=0.25*(dt/dx)*((U(i+1,t-1))**2.-(U(i-1,t-1))**2.)
!!$        !write(*,*) 'L1(i,t-1)', L1(i,t-1)
!!$
!!$        Aplus(i,t-1)=0.5*( U(i,t-1) + U(i+1,t-1)   )
!!$        !write(*,*) 'Aplus', Aplus(i,t-1)
!!$
!!$        Aminus(i,t-1)=0.5*( U(i,t-1) + U(i-1,t-1)   )
!!$        !write(*,*) 'Aminus', Aminus(i,t-1)
!!$
!!$        Fplus(i,t-1)=(U(i+1,t-1))**2.-(U(i,t-1))**2.  !* remember to include the 1/2 's *!
!!$        Fminus(i,t-1)=(U(i,t-1))**2.-(U(i-1,t-1))**2.
!!$
!!$        L2(i,t-1)=0.25*((dt/dx)**2.)*((Aplus(i,t-1)*Fplus(i,t-1))-(Aminus(i,t-1)*Fminus(i,t-1)))
!!$        write(*,*) 'L2', L2(i,t-1)
!!$        U(i,t) =U(i,t-1) - L1(i,t-1) + L2(i,t-1)
!!$        write(*,*) ' X(i)   u(x,t)   ', X(i), U(i,t)
!!$     end do
!!$     write(*,*) 'End timestep t'
!!$    ! pause
!!$  end do

  Write (*,*) '------------------Begin Implicit Euler Method--------------------------'
  ! NI is the number of elements in the diagonal
  ! am is the subdiagonal
  ! bm is the diagonal
  ! cm is the superdiagonal
  ! F(:,t-1) is the RHS
  ! delta(:,t) is the Solution at time t
  ! t is indexed from 0 to 30.  NT=30

  Do t=1,NT

  Do i=1,NI-2  !!! Make the Delta matrix which excludes the bc's
     Delta(i,t-1)=0.0
  End do

     ! Compute the Subdiagonal, a, Diagonal, b, And Superdiagonal, c, Terms
     !Delta(1,t-1)=1.5!U(1,t-2)
     !Delta(NI,t-1)=0.5!U(NI,t-2)
     Do i=2,NI
        write(*,*) 'i, t, Unm(i,t-1)', i, t, Unm(i,t-1)
        write(*,*) 'i,t,Unm(i-1,t-1)', i, t, Unm(i-1,t-1)
        write(*,*) ''
     End do

     !!Do the Newton Iterations from 1-10
     mmax=10
     do m=1,mmax
        write(*,*)  'Begin m loop'
        !pause!----------------------------------------
        do i=1,NI-3
           !!am(i)=(-dt/(2.*dx))*Delta(i-1,t-1)
           am(i)=(dt/dx)*Unm(i+2,t-1)   !! Range = 3,NI-1
        End do

        do i=2,NI-2
           !!cm(i)=(dt/(2.*dx))*Delta(i+1,t-1)
           cm(i)=0.0    !! Range = 2,NI-2
        End do

        do i=1,NI-2
           Fplus(i,t-1) =((Unm(i+1,t-1))**2.)  !! Range = 2,NI-1
           Fminus(i,t-1)=((Unm(i,t-1))**2.)    !! Range = 1,NI-2
           F(i,t-1)=Unm(i+1,t-1)-U(i+1,t-1)+0.5*dt*(Fplus(i,t-1)-Fminus(i,t-1))/dx

           bm(i)=1.0+(dt/dx)*Unm(i+1,t-1)   !! Range = 2,NI-1

        end do

!!$        do i=1,NI-2
!!$
!!$        end do

      !   write(*,*) 'a', am(:)
      !   write(*,*) ''
      !   write(*,*) 'b', bm(:)
      !   write(*,*) ''
      !   write(*,*) 'c', cm(:)
      !   write(*,*) ''
        !! Solve for the delta U(:,t)

        !! Call my solver
        !Call tlmtri (am(:),bm(:),cm(:),-.5*(dt/dx)*(Fplus(:,t-1)-Fminus(:,t-1)),Delta(:,t),NI-2)

        !! Call Swaff Solver
        Call trid (am,bm,cm,-F(:,t-1),Delta(:,t),NI-2)

        !Do i=1,NI-2
        !   write(*,*) 'am, bm, cm, Fplus, Fminus, F', am(i), bm(i), cm(i), Fplus(i,t-1), Fminus(i,t-1), F(i,t-1)
        !End Do

        Do i=1,NI-2
           Unm(i+1,t-1)=Delta(i,t)+Unm(i+1,t-1)  !!Caareful, Unm range = [1,NI]
           !write(*,*) 'Delta(i,t,m+1), Delta(i,t,m), Unm(i,t-1)', Delta(i,t), Delta(i,t-1), Unm(i,t-1)
        End Do

!!$        !!Convert to U(:,t-1)
!!$        Do i=1,NI-2
!!$           U(i+1,t)=Delta(i,t)+U(i+1,t-1)
!!$        End Do

     End do  !! End the iterative m loop for implicit NM.

     !!Convert to U(:,t)
     Do i=1,NI-2
        U(i+1,t)=Unm(i+1,t-1) !!Updating inner range = [2,NI-1] could try whole domain but this should work...
        Unm(i+1,t)=Unm(i+1,t-1)
     End Do

!! Should be able to include these immediately above since they never change...
     U(1,t)=1.5
     U(NI,t)=0.5
     Unm(1,t)=1.5
     Unm(NI,t)=0.5

     write(6,*) 'Timestep', T
     Do i=1,NI
        write(*,*) 'new U(i,t)', U(i,t)
     End do
  End do    !! End Timestep

!!----------------------------End Euler Scheme----------------------------------------

!!----------------------------Exact Solution----------------------------------------

 !Do t=1,NT

 t=40*dt
    Do i=1,NI
       Uexact(i,40)=U(i,0)
    End Do
 !End Do
 print*
 Write(6,*) 'exact solution at t=40'
 Do i=1,NI
    write(*,*) ' Uexact ', Uexact(i,40)
 End do

 Write(6,*) 'end exact solution at t=40'
!!----------------------------End Exact Solution----------------------------------------

  Write(6,*) 'output GNUplot file'
  ! output Gnuplot file
  OPEN(UNIT=1, FILE='EulerImplicit.dat',FORM='FORMATTED',STATUS='REPLACE')!,IOSTAT=ios)
  !IF (ios /= 0) THEN
  !  PRINT *, "Error opening Gnu plot file "
  !  STOP
  !END IF

  Write(6,*) 'output x,U'
  Do t=1, 5
     DO i=1, NI
        !WRITE(UNIT=1,FMT='(E19.10," ",E19.10," 0.0")') x(i,it1(t)),u(i,it1(t))
        WRITE(UNIT=1,FMT='(E19.10," ",E19.10)') x(i),U(i,it1(t))
     END DO
     WRITE(UNIT=1,FMT='(" ")')
  End Do

  Write(6,*) 'output x,Uexact'
  Do i=1,NI
     WRITE(UNIT=1,FMT='(E19.10," ",E19.10)') x(i)+dt*Nt*0.5*(1.5+.5),Uexact(i,40)
  End do
  CLOSE(UNIT=1)

!! Plotting in gnu plot
!! once in the proper directory in terminal, open a second tab
!! type:  gnuplot   to open gnuplot
!! type:  plot "Gnu.dat" w l        to plot

  Write(6,*) 'deallocating'

!!$  IF (ALLOCATED(Points)) DEALLOCATE(Points)
!!$  IF (ALLOCATED(S)) DEALLOCATE(S)
!!$  IF (ALLOCATED(T)) DEALLOCATE(T)
!!$  IF (ALLOCATED(To)) DEALLOCATE(To)
!!$  IF (ALLOCATED(Treal)) DEALLOCATE(Treal)

  Write(6,*) 'deallocating 1'
  IF (ALLOCATED(X)) DEALLOCATE(X)
  IF (ALLOCATED(U)) DEALLOCATE(U)
  IF (ALLOCATED(Uexact)) DEALLOCATE(Uexact)
  IF (ALLOCATED(am)) DEALLOCATE(am)
  IF (ALLOCATED(bm)) DEALLOCATE(bm)
  IF (ALLOCATED(cm)) DEALLOCATE(cm)

  Write(6,*) 'deallocating 2'
  IF (ALLOCATED(L1)) DEALLOCATE(L1)
  IF (ALLOCATED(L2)) DEALLOCATE(L2)
  IF (ALLOCATED(Aplus)) DEALLOCATE(Aplus)
  IF (ALLOCATED(Aminus)) DEALLOCATE(Aminus)

  Write(6,*) 'deallocating 4'
  IF (ALLOCATED(Delta)) DEALLOCATE(Delta)
  IF (ALLOCATED(RHS)) DEALLOCATE(RHS)
  if (allocated(Unm)) deallocate(Unm)

  Write(6,*) 'deallocating Fplus'
  IF (ALLOCATED(Fplus)) DEALLOCATE(Fplus)
  Write(6,*) 'deallocating Fminus'
  IF (ALLOCATED(Fminus)) DEALLOCATE(Fminus)
  Write(6,*) 'deallocating F'
  IF (ALLOCATED(F)) DEALLOCATE(F)

END PROGRAM solver