!
!     part of SLATEC (en.wikipedia.org/wiki/FFTPACK): public domain
!
!                      FFTPACK
!
!* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!                  version 4  april 1985
!
!     a package of fortran subprograms for the fast fourier
!      transform of periodic and other symmetric sequences
!
!                         by
!
!                  paul n swarztrauber
!
!  national center for atmospheric research  boulder,colorado 80307
!
!   which is sponsored by the national science foundation
!
!     CHANGED ON 11 May 2005 by Guido Dhondt:
!        1. introduced array isave (compatibility with ifac in drfftf1)
!        2. changed real to double
!
!* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!this package consists of programs which perform fast fourier
!transforms for both complex and real periodic sequences and
!certain other symmetric sequences that are listed below.
!
!1.   drffti     initialize  drfftf and rfftb
!2.   drfftf     forward transform of a real periodic sequence
!
!
!******************************************************************
!
!subroutine drffti(n,wsave,isave)
!
!  ****************************************************************
!
!subroutine drffti initializes the array wsave which is used in
!both drfftf and rfftb. the prime factorization of n together with
!a tabulation of the trigonometric functions are computed and
!stored in wsave.
!
!input parameter
!
!n       the length of the sequence to be transformed.
!
!output parameter
!
!wsave   a work array which must be dimensioned at least 2*n.
!        the same work array can be used for both drfftf and rfftb
!        as long as n remains unchanged. different wsave arrays
!        are required for different values of n. the contents of
!        wsave must not be changed between calls of drfftf or rfftb.
!isave   a work array which must be dimensioned at least 15.
!
!******************************************************************
!
!subroutine drfftf(n,r,wsave,isave)
!
!******************************************************************
!
!subroutine drfftf computes the fourier coefficients of a real
!perodic sequence (fourier analysis). the transform is defined
!below at output parameter r.
!
!input parameters
!
!n       the length of the array r to be transformed.  the method
!        is most efficient when n is a product of small primes.
!        n may change so long as different work arrays are provided
!
!r       a real array of length n which contains the sequence
!        to be transformed
!
!wsave   a work array which must be dimensioned at least 2*n.
!        in the program that calls drfftf. the wsave array must be
!        initialized by calling subroutine drffti(n,wsave) and a
!        different wsave array must be used for each different
!        value of n. this initialization does not have to be
!        repeated so long as n remains unchanged thus subsequent
!        transforms can be obtained faster than the first.
!        the same wsave array can be used by drfftf and rfftb.
!isave   a work array which must be dimensioned at least 15.
!
!
!output parameters
!
!r       r(1) = the sum from i=1 to i=n of r(i)
!
!        if n is even set l =n/2   , if n is odd set l = (n+1)/2
!
!          then for k = 2,...,l
!
!             r(2*k-2) = the sum from i = 1 to i = n of
!
!                  r(i)*cos((k-1)*(i-1)*2*pi/n)
!
!             r(2*k-1) = the sum from i = 1 to i = n of
!
!                 -r(i)*sin((k-1)*(i-1)*2*pi/n)
!
!        if n is even
!
!             r(n) = the sum from i = 1 to i = n of
!
!                  (-1)**(i-1)*r(i)
!
! *****  note
!             this transform is unnormalized since a call of drfftf
!             followed by a call of rfftb will multiply the input
!             sequence by n.
!
!wsave   contains results which must not be destroyed between
!        calls of drfftf or rfftb.
!
!
      SUBROUTINE RADF2 (IDO,L1,CC,CH,WA1)
      implicit real*8(a-h,o-z)
      DIMENSION       CH(IDO,2,L1)           ,CC(IDO,L1,2)           ,
     1                WA1(1)
      DO 101 K=1,L1
         CH(1,1,K) = CC(1,K,1)+CC(1,K,2)
         CH(IDO,2,K) = CC(1,K,1)-CC(1,K,2)
  101 CONTINUE
      IF (IDO-2) 107,105,102
  102 IDP2 = IDO+2
      DO 104 K=1,L1
         DO 103 I=3,IDO,2
            IC = IDP2-I
            TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            CH(I,1,K) = CC(I,K,1)+TI2
            CH(IC,2,K) = TI2-CC(I,K,1)
            CH(I-1,1,K) = CC(I-1,K,1)+TR2
            CH(IC-1,2,K) = CC(I-1,K,1)-TR2
  103    CONTINUE
  104 CONTINUE
      IF (MOD(IDO,2) .EQ. 1) RETURN
  105 DO 106 K=1,L1
         CH(1,2,K) = -CC(IDO,K,2)
         CH(IDO,1,K) = CC(IDO,K,1)
  106 CONTINUE
  107 RETURN
      END
      SUBROUTINE RADF3 (IDO,L1,CC,CH,WA1,WA2)
      implicit real*8(a-h,o-z)
      DIMENSION       CH(IDO,3,L1)           ,CC(IDO,L1,3)           ,
     1                WA1(1)     ,WA2(1)
      DATA TAUR,TAUI /-.5,.866025403784439/
      DO 101 K=1,L1
         CR2 = CC(1,K,2)+CC(1,K,3)
         CH(1,1,K) = CC(1,K,1)+CR2
         CH(1,3,K) = TAUI*(CC(1,K,3)-CC(1,K,2))
         CH(IDO,2,K) = CC(1,K,1)+TAUR*CR2
  101 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IDP2 = IDO+2
      DO 103 K=1,L1
         DO 102 I=3,IDO,2
            IC = IDP2-I
            DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
            DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
            CR2 = DR2+DR3
            CI2 = DI2+DI3
            CH(I-1,1,K) = CC(I-1,K,1)+CR2
            CH(I,1,K) = CC(I,K,1)+CI2
            TR2 = CC(I-1,K,1)+TAUR*CR2
            TI2 = CC(I,K,1)+TAUR*CI2
            TR3 = TAUI*(DI2-DI3)
            TI3 = TAUI*(DR3-DR2)
            CH(I-1,3,K) = TR2+TR3
            CH(IC-1,2,K) = TR2-TR3
            CH(I,3,K) = TI2+TI3
            CH(IC,2,K) = TI3-TI2
  102    CONTINUE
  103 CONTINUE
      RETURN
      END
      SUBROUTINE RADF4 (IDO,L1,CC,CH,WA1,WA2,WA3)
      implicit real*8(a-h,o-z)
      DIMENSION       CC(IDO,L1,4)           ,CH(IDO,4,L1)           ,
     1                WA1(1)     ,WA2(1)     ,WA3(1)
      DATA HSQT2 /.7071067811865475/
      DO 101 K=1,L1
         TR1 = CC(1,K,2)+CC(1,K,4)
         TR2 = CC(1,K,1)+CC(1,K,3)
         CH(1,1,K) = TR1+TR2
         CH(IDO,4,K) = TR2-TR1
         CH(IDO,2,K) = CC(1,K,1)-CC(1,K,3)
         CH(1,3,K) = CC(1,K,4)-CC(1,K,2)
  101 CONTINUE
      IF (IDO-2) 107,105,102
  102 IDP2 = IDO+2
      DO 104 K=1,L1
         DO 103 I=3,IDO,2
            IC = IDP2-I
            CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
            CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
            CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
            CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
            TR1 = CR2+CR4
            TR4 = CR4-CR2
            TI1 = CI2+CI4
            TI4 = CI2-CI4
            TI2 = CC(I,K,1)+CI3
            TI3 = CC(I,K,1)-CI3
            TR2 = CC(I-1,K,1)+CR3
            TR3 = CC(I-1,K,1)-CR3
            CH(I-1,1,K) = TR1+TR2
            CH(IC-1,4,K) = TR2-TR1
            CH(I,1,K) = TI1+TI2
            CH(IC,4,K) = TI1-TI2
            CH(I-1,3,K) = TI4+TR3
            CH(IC-1,2,K) = TR3-TI4
            CH(I,3,K) = TR4+TI3
            CH(IC,2,K) = TR4-TI3
  103    CONTINUE
  104 CONTINUE
      IF (MOD(IDO,2) .EQ. 1) RETURN
  105 CONTINUE
      DO 106 K=1,L1
         TI1 = -HSQT2*(CC(IDO,K,2)+CC(IDO,K,4))
         TR1 = HSQT2*(CC(IDO,K,2)-CC(IDO,K,4))
         CH(IDO,1,K) = TR1+CC(IDO,K,1)
         CH(IDO,3,K) = CC(IDO,K,1)-TR1
         CH(1,2,K) = TI1-CC(IDO,K,3)
         CH(1,4,K) = TI1+CC(IDO,K,3)
  106 CONTINUE
  107 RETURN
      END
      SUBROUTINE RADF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4)
      implicit real*8(a-h,o-z)
      DIMENSION       CC(IDO,L1,5)           ,CH(IDO,5,L1)           ,
     1                WA1(1)     ,WA2(1)     ,WA3(1)     ,WA4(1)
      DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154,
     1-.809016994374947,.587785252292473/
      DO 101 K=1,L1
         CR2 = CC(1,K,5)+CC(1,K,2)
         CI5 = CC(1,K,5)-CC(1,K,2)
         CR3 = CC(1,K,4)+CC(1,K,3)
         CI4 = CC(1,K,4)-CC(1,K,3)
         CH(1,1,K) = CC(1,K,1)+CR2+CR3
         CH(IDO,2,K) = CC(1,K,1)+TR11*CR2+TR12*CR3
         CH(1,3,K) = TI11*CI5+TI12*CI4
         CH(IDO,4,K) = CC(1,K,1)+TR12*CR2+TR11*CR3
         CH(1,5,K) = TI12*CI5-TI11*CI4
  101 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IDP2 = IDO+2
      DO 103 K=1,L1
         DO 102 I=3,IDO,2
            IC = IDP2-I
            DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
            DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
            DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
            DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
            DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5)
            DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5)
            CR2 = DR2+DR5
            CI5 = DR5-DR2
            CR5 = DI2-DI5
            CI2 = DI2+DI5
            CR3 = DR3+DR4
            CI4 = DR4-DR3
            CR4 = DI3-DI4
            CI3 = DI3+DI4
            CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3
            CH(I,1,K) = CC(I,K,1)+CI2+CI3
            TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3
            TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3
            TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3
            TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3
            TR5 = TI11*CR5+TI12*CR4
            TI5 = TI11*CI5+TI12*CI4
            TR4 = TI12*CR5-TI11*CR4
            TI4 = TI12*CI5-TI11*CI4
            CH(I-1,3,K) = TR2+TR5
            CH(IC-1,2,K) = TR2-TR5
            CH(I,3,K) = TI2+TI5
            CH(IC,2,K) = TI5-TI2
            CH(I-1,5,K) = TR3+TR4
            CH(IC-1,4,K) = TR3-TR4
            CH(I,5,K) = TI3+TI4
            CH(IC,4,K) = TI4-TI3
  102    CONTINUE
  103 CONTINUE
      RETURN
      END
      SUBROUTINE RADFG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)
      implicit real*8(a-h,o-z)
      DIMENSION       CH(IDO,L1,IP)          ,CC(IDO,IP,L1)          ,
     1                C1(IDO,L1,IP)          ,C2(IDL1,IP),
     2                CH2(IDL1,IP)           ,WA(1)
      DATA TPI/6.28318530717959/
      ARG = TPI/FLOAT(IP)
      DCP = COS(ARG)
      DSP = SIN(ARG)
      IPPH = (IP+1)/2
      IPP2 = IP+2
      IDP2 = IDO+2
      NBD = (IDO-1)/2
      IF (IDO .EQ. 1) GO TO 119
      DO 101 IK=1,IDL1
         CH2(IK,1) = C2(IK,1)
  101 CONTINUE
      DO 103 J=2,IP
         DO 102 K=1,L1
            CH(1,K,J) = C1(1,K,J)
  102    CONTINUE
  103 CONTINUE
      IF (NBD .GT. L1) GO TO 107
      IS = -IDO
      DO 106 J=2,IP
         IS = IS+IDO
         IDIJ = IS
         DO 105 I=3,IDO,2
            IDIJ = IDIJ+2
            DO 104 K=1,L1
               CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J)
               CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J)
  104       CONTINUE
  105    CONTINUE
  106 CONTINUE
      GO TO 111
  107 IS = -IDO
      DO 110 J=2,IP
         IS = IS+IDO
         DO 109 K=1,L1
            IDIJ = IS
            DO 108 I=3,IDO,2
               IDIJ = IDIJ+2
               CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J)
               CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J)
  108       CONTINUE
  109    CONTINUE
  110 CONTINUE
  111 IF (NBD .LT. L1) GO TO 115
      DO 114 J=2,IPPH
         JC = IPP2-J
         DO 113 K=1,L1
            DO 112 I=3,IDO,2
               C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC)
               C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC)
               C1(I,K,J) = CH(I,K,J)+CH(I,K,JC)
               C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J)
  112       CONTINUE
  113    CONTINUE
  114 CONTINUE
      GO TO 121
  115 DO 118 J=2,IPPH
         JC = IPP2-J
         DO 117 I=3,IDO,2
            DO 116 K=1,L1
               C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC)
               C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC)
               C1(I,K,J) = CH(I,K,J)+CH(I,K,JC)
               C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J)
  116       CONTINUE
  117    CONTINUE
  118 CONTINUE
      GO TO 121
  119 DO 120 IK=1,IDL1
         C2(IK,1) = CH2(IK,1)
  120 CONTINUE
  121 DO 123 J=2,IPPH
         JC = IPP2-J
         DO 122 K=1,L1
            C1(1,K,J) = CH(1,K,J)+CH(1,K,JC)
            C1(1,K,JC) = CH(1,K,JC)-CH(1,K,J)
  122    CONTINUE
  123 CONTINUE
C
      AR1 = 1.
      AI1 = 0.
      DO 127 L=2,IPPH
         LC = IPP2-L
         AR1H = DCP*AR1-DSP*AI1
         AI1 = DCP*AI1+DSP*AR1
         AR1 = AR1H
         DO 124 IK=1,IDL1
            CH2(IK,L) = C2(IK,1)+AR1*C2(IK,2)
            CH2(IK,LC) = AI1*C2(IK,IP)
  124    CONTINUE
         DC2 = AR1
         DS2 = AI1
         AR2 = AR1
         AI2 = AI1
         DO 126 J=3,IPPH
            JC = IPP2-J
            AR2H = DC2*AR2-DS2*AI2
            AI2 = DC2*AI2+DS2*AR2
            AR2 = AR2H
            DO 125 IK=1,IDL1
               CH2(IK,L) = CH2(IK,L)+AR2*C2(IK,J)
               CH2(IK,LC) = CH2(IK,LC)+AI2*C2(IK,JC)
  125       CONTINUE
  126    CONTINUE
  127 CONTINUE
      DO 129 J=2,IPPH
         DO 128 IK=1,IDL1
            CH2(IK,1) = CH2(IK,1)+C2(IK,J)
  128    CONTINUE
  129 CONTINUE
C
      IF (IDO .LT. L1) GO TO 132
      DO 131 K=1,L1
         DO 130 I=1,IDO
            CC(I,1,K) = CH(I,K,1)
  130    CONTINUE
  131 CONTINUE
      GO TO 135
  132 DO 134 I=1,IDO
         DO 133 K=1,L1
            CC(I,1,K) = CH(I,K,1)
  133    CONTINUE
  134 CONTINUE
  135 DO 137 J=2,IPPH
         JC = IPP2-J
         J2 = J+J
         DO 136 K=1,L1
            CC(IDO,J2-2,K) = CH(1,K,J)
            CC(1,J2-1,K) = CH(1,K,JC)
  136    CONTINUE
  137 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IF (NBD .LT. L1) GO TO 141
      DO 140 J=2,IPPH
         JC = IPP2-J
         J2 = J+J
         DO 139 K=1,L1
            DO 138 I=3,IDO,2
               IC = IDP2-I
               CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC)
               CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC)
               CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC)
               CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J)
  138       CONTINUE
  139    CONTINUE
  140 CONTINUE
      RETURN
  141 DO 144 J=2,IPPH
         JC = IPP2-J
         J2 = J+J
         DO 143 I=3,IDO,2
            IC = IDP2-I
            DO 142 K=1,L1
               CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC)
               CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC)
               CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC)
               CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J)
  142       CONTINUE
  143    CONTINUE
  144 CONTINUE
      RETURN
      END
      SUBROUTINE dRFFTF (N,R,WSAVE,isave)
      implicit real*8(a-h,o-z)
      DIMENSION       R(1)       ,WSAVE(*),isave(*)
      IF (N .EQ. 1) RETURN
      CALL DRFFTF1 (N,R,WSAVE,WSAVE(N+1),isave)
      RETURN
      END
      SUBROUTINE DRFFTF1 (N,C,CH,WA,IFAC)
      implicit real*8(a-h,o-z)
      DIMENSION       CH(1)      ,C(1)       ,WA(1)      ,IFAC(*)
      NF = IFAC(2)
      NA = 1
      L2 = N
      IW = N
      DO 111 K1=1,NF
         KH = NF-K1
         IP = IFAC(KH+3)
         L1 = L2/IP
         IDO = N/L2
         IDL1 = IDO*L1
         IW = IW-(IP-1)*IDO
         NA = 1-NA
         IF (IP .NE. 4) GO TO 102
         IX2 = IW+IDO
         IX3 = IX2+IDO
         IF (NA .NE. 0) GO TO 101
         CALL RADF4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
         GO TO 110
  101    CALL RADF4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
         GO TO 110
  102    IF (IP .NE. 2) GO TO 104
         IF (NA .NE. 0) GO TO 103
         CALL RADF2 (IDO,L1,C,CH,WA(IW))
         GO TO 110
  103    CALL RADF2 (IDO,L1,CH,C,WA(IW))
         GO TO 110
  104    IF (IP .NE. 3) GO TO 106
         IX2 = IW+IDO
         IF (NA .NE. 0) GO TO 105
         CALL RADF3 (IDO,L1,C,CH,WA(IW),WA(IX2))
         GO TO 110
  105    CALL RADF3 (IDO,L1,CH,C,WA(IW),WA(IX2))
         GO TO 110
  106    IF (IP .NE. 5) GO TO 108
         IX2 = IW+IDO
         IX3 = IX2+IDO
         IX4 = IX3+IDO
         IF (NA .NE. 0) GO TO 107
         CALL RADF5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
         GO TO 110
  107    CALL RADF5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
         GO TO 110
  108    IF (IDO .EQ. 1) NA = 1-NA
         IF (NA .NE. 0) GO TO 109
         CALL RADFG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
         NA = 1
         GO TO 110
  109    CALL RADFG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
         NA = 0
  110    L2 = L1
  111 CONTINUE
      IF (NA .EQ. 1) RETURN
      DO 112 I=1,N
         C(I) = CH(I)
  112 CONTINUE
      RETURN
      END
      SUBROUTINE dRFFTI (N,WSAVE,isave)
      implicit real*8(a-h,o-z)
      DIMENSION       WSAVE(*),isave(*)
      IF (N .EQ. 1) RETURN
      CALL DRFFTI1 (N,WSAVE(N+1),isave)
      RETURN
      END
      SUBROUTINE DRFFTI1 (N,WA,IFAC)
      implicit real*8(a-h,o-z)
      DIMENSION       WA(1)      ,IFAC(*)    ,NTRYH(4)
      DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/
      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)
      IS = 0
      NFM1 = NF-1
      L1 = 1
      IF (NFM1 .EQ. 0) RETURN
      DO 110 K1=1,NFM1
         IP = IFAC(K1+2)
         LD = 0
         L2 = L1*IP
         IDO = N/L2
         IPM = IP-1
         DO 109 J=1,IPM
            LD = LD+L1
            I = IS
            ARGLD = FLOAT(LD)*ARGH
            FI = 0.
            DO 108 II=3,IDO,2
               I = I+2
               FI = FI+1.
               ARG = FI*ARGLD
               WA(I-1) = COS(ARG)
               WA(I) = SIN(ARG)
  108       CONTINUE
            IS = IS+IDO
  109    CONTINUE
         L1 = L2
  110 CONTINUE
      RETURN
      END


subroutine a_mul_b_rr( nthreads, nvec, n, m, alpha, beta, A, jA, iA, x, y )
!DIR$ ATTRIBUTES DLLEXPORT :: a_mul_b_rr
!DIR$ ATTRIBUTES ALIAS: 'a_mul_b_rr_':: a_mul_b_rr

! y = beta*y  +  alpha * A*x

use omp_lib
implicit none

integer(kind=8),intent(in):: nthreads
integer(kind=8),intent(in):: nvec
integer(kind=8),intent(in):: n  ! # of columns in A
integer(kind=8),intent(in):: m  ! # of rows in A

real(kind=8),intent(in):: alpha, beta
real(kind=8),intent(in):: A(*)
integer(kind=8),intent(in):: jA(*), iA(n+1)
real(kind=8),intent(in):: x(n,nvec)
real(kind=8),intent(inout):: y(m,nvec)

integer ivec, i, j1,j2, j, jaj, mythread, mm, jm
real(kind=8) xi
real(kind=8),allocatable:: yt(:)

include "A_mul_B.fi"

return
end subroutine a_mul_b_rr

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

subroutine a_mul_b_rc( nthreads, nvec, n, m, alpha, beta, A, jA, iA, x, y )
!DIR$ ATTRIBUTES DLLEXPORT :: a_mul_b_rc
!DIR$ ATTRIBUTES ALIAS: 'a_mul_b_rc_':: a_mul_b_rc

! y = beta*y  +  alpha * A*x

use omp_lib
implicit none

integer(kind=8),intent(in):: nthreads
integer(kind=8),intent(in):: nvec
integer(kind=8),intent(in):: n  ! # of columns in A
integer(kind=8),intent(in):: m  ! # of rows in A

complex(kind=8),intent(in):: alpha, beta
real(kind=8),intent(in):: A(*)
integer(kind=8),intent(in):: jA(*), iA(n+1)
complex(kind=8),intent(in):: x(n,nvec)
complex(kind=8),intent(inout):: y(m,nvec)

integer ivec, i, j1,j2, j, jaj, mythread, mm, jm
complex(kind=8) xi
complex(kind=8),allocatable:: yt(:)

include "A_mul_B.fi"

return
end subroutine a_mul_b_rc

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

subroutine a_mul_b_cc( nthreads, nvec, n, m, alpha, beta, A, jA, iA, x, y )
!DIR$ ATTRIBUTES DLLEXPORT :: a_mul_b_cc
!DIR$ ATTRIBUTES ALIAS: 'a_mul_b_cc_':: a_mul_b_cc

! y = beta*y  +  alpha * A*x

use omp_lib
implicit none

integer(kind=8),intent(in):: nthreads
integer(kind=8),intent(in):: nvec
integer(kind=8),intent(in):: n  ! # of columns in A
integer(kind=8),intent(in):: m  ! # of rows in A

complex(kind=8),intent(in):: alpha, beta
complex(kind=8),intent(in):: A(*)
integer(kind=8),intent(in):: jA(*), iA(n+1)
complex(kind=8),intent(in):: x(n,nvec)
complex(kind=8),intent(inout):: y(m,nvec)

integer ivec, i, j1,j2, j, jaj, mythread, mm, jm
complex(kind=8) xi
complex(kind=8),allocatable:: yt(:)

include "A_mul_B.fi"

return
end subroutine a_mul_b_cc


module eval_core_neutrino
    use neutrino_def
    use constants_def
    real(dp), parameter :: threepithird = threepisquare**one_third

contains

    subroutine emissivity(nn,np,T,Tcs,include_channel,eps)
        use superfluid_def, only: max_number_sf_types, proton_1S0, neutron_1S0, neutron_3P2
        !INPUT: nn, np: densities (fm^-3^) of n, p
        !               T is temperature in K, Tcs are critcal temperatures
        real(dp), intent(in) :: nn,np,T,Tcs(max_number_sf_types)
        logical, dimension(num_core_nu_channels), intent(in) :: include_channel
        type(core_neutrino_emissivity_channels), intent(out) :: eps
        real(dp) :: tps, tns, tnt, vps, vns, vnt, istps, istns, T9

        tps = T/Tcs(proton_1S0)
        tns = T/Tcs(neutron_1S0)
        tnt = T/Tcs(neutron_3P2)
        T9 = T*1.0e-9_dp

        istps = 1.0_dp/sqrt(tps)
        istns = 1.0_dp/sqrt(tns)
        vps = 0.0_dp
        if(tps < 1.0_dp)  &
            & vps = sqrt(1.0_dp-tps)*(1.456_dp+istps*(-0.157_dp+istps*1.764_dp))
        vns = 0.0_dp
        if(tns < 1.0_dp) &
            & vns = sqrt(1.0_dp-tns)*(1.456_dp+istns*(-0.157_dp+istns*1.764_dp))
        vnt = 0.0_dp
        if(tnt < 1.0_dp) vnt = sqrt(1.0_dp-tnt)*(0.7893_dp+1.188_dp/tnt)

        call clear_epsilon
        if (include_channel(icore_nu_brem)) call nubrems( &
            & nn,np,T9,vps,vns,vnt,eps% brem, &
            & eps% brem_np, eps% brem_pp, eps% brem_nn)

        if (include_channel(icore_nu_mUrca)) call mUrca( &
            & nn,np,T9,vps,vns,vnt,eps% mUrca, eps% mUrca_p, eps% mUrca_n)

        if (include_channel(icore_nu_dUrca)) call dUrca( &
            & nn,np,T9,vps,vns,vnt,eps% dUrca)

        if (include_channel(icore_nu_PBF)) call nupbf( &
            & nn,np,T9,vps,vns,vnt,eps% PBF, eps% PBF_n, eps% PBF_p)

        ! sum contributions
        eps% total = eps% brem + eps% mUrca + eps% dUrca + eps% PBF

        contains
        subroutine clear_epsilon()
            eps% total = 0.0_dp
            eps% brem = 0.0_dp; eps% brem_np = 0.0_dp
            eps% brem_pp = 0.0_dp; eps% brem_nn = 0.0_dp
            eps% mUrca = 0.0_dp; eps% mUrca_p = 0.0_dp; eps% mUrca_n = 0.0_dp
            eps% dUrca = 0.0_dp
            eps% PBF = 0.0_dp; eps% PBF_n = 0.0_dp; eps% PBF_p = 0.0_dp
        end subroutine clear_epsilon
    end subroutine emissivity

    subroutine nubrems(nn,np,T9,vps,vns,vnt,eps,eps_np,eps_pp,eps_nn)
        ! bremsstrahlung
        real(dp), intent(in) :: nn,np,T9,vps,vns,vnt
        real(dp), intent(out) :: eps,eps_np, eps_pp, eps_nn
        real(dp), parameter :: Qnn = 7.4e19_dp, Qnp = 1.5e20_dp, Qpp = 7.4e19_dp
        real(dp) :: T98, rbpnp, rbppp, rbnns, rbnnt, rbnnn, rbnp, rda, rdb, rd, ap, bp, cp, ddp, cn, dn

        T98 = T9**8
        rbpnp = 1.0_dp
        rbppp = 1.0_dp
        if (vps > 0.0_dp) then
            ap = 0.9982 + sqrt(0.0018**2+(0.3815*vps)**2)
            bp = 0.3949 + sqrt(0.6051**2+(0.2666*vps)**2)
            cp = 0.1747 + sqrt(0.8253**2+(0.07933*vps)**2)
            ddp = 0.7333 + sqrt(0.2667**2+(0.1678*vps)**2)
            rbpnp = (1.0/2.732)*(ap*exp(1.306-sqrt(1.306**2+vps**2)) &
                & + 1.732*bp**7*exp(3.303-sqrt(3.303**2+4.0*vps**2)))
            rbppp = 0.5*(cp**2*exp(4.228-sqrt(4.228**2+(2*vps)**2)) &
                & + ddp**7.5*exp(7.762-sqrt(7.762**2+(3.0*vps)**2)))
        end if

        rbnns = 1.0_dp
        if (vns > 0.0) then
            cn = 0.1747 + sqrt(0.8253**2+(0.07933*vns)**2)
            dn = 0.7333 + sqrt(0.2667**2+(0.1678*vns)**2)
            rbnns = 0.5*(cn**2*exp(4.228-sqrt(4.228**2+(2*vns)**2)) &
                & + dn**7.5*exp(7.762-sqrt(7.762**2+(3.0*vns)**2)))
        end if

        rbnnt = 1.0
        if (vnt > 0.0) then
            cn = 0.1747 + sqrt(0.8253**2+(0.07933*vnt)**2)
            dn = 0.7333 + sqrt(0.2667**2+(0.1678*vnt)**2)
            rbnnt = 0.5*(cn**2*exp(4.228-sqrt(4.228**2+(2*vnt)**2)) &
                & + dn**7.5*exp(7.762-sqrt(7.762**2+(3.0*vnt)**2)))
        end if

        rda = 1.0
        if(vps > 0.0) rda = (0.2312 + sqrt((0.7688)**2+(0.1438*vps)**2))**5.5 &
            & *exp(3.427*(1.0-sqrt(1.0+(vps/3.427)**2)))
        rdb = 1.0
        if(vnt > 0.0) rdb = (0.2546 + sqrt((0.7454)**2 + (0.1284*vnt)**2))**5 &
            & *exp(2.701*(1.0-sqrt(1.0+(vnt/2.701)**2)))
        rd = min(rda,rdb)

        rbnnn = min(rbnns, rbnnt)
        rbnp = rbpnp
        if (rda > 0.0) rbnp = (rd/rda)*rbnp

        eps_np = Qnp*T98*rbnp
        eps_pp = Qpp*T98*rbppp
        eps_nn = Qnn*T98*rbnnn
        eps = T98*(Qnp*rbnp + Qpp*rbppp + Qnn*rbnnn)
    end subroutine nubrems

    subroutine mUrca(nn,np,T9,vps,vns,vnt,eps, eps_p, eps_n)
    ! modified Urca
        real(dp), intent(in) :: nn, np, T9, vps, vns, vnt
        real(dp), intent(out) :: eps, eps_p, eps_n
        real(dp), parameter :: Qn = 8.55e21_dp, Qp = 8.53e21_dp
        real(dp) :: T98, rmp, rmn, aa, ba, rmpa, rmpb, ab, bb

        T98 = T9**8

        ! neutron branch
        rmn = 1.0
        if (vps > 0.0) then
            aa = 0.1477 + sqrt((0.8523)**2+(0.1175*vps)**2)
            ba = 0.1477 + sqrt((0.8523)**2+(0.1297*vps)**2)
            rmn = 0.5*(aa**7.5 +ba**5.5)*exp(3.4370*(1.0-sqrt(1.0+(vps/3.4370)**2)))
        end if

        ! proton branch
        rmpa = (0.2414+sqrt((0.7586)**2+(0.1318*vps)**2))**7 &
                & *exp(5.339*(1.0-sqrt(1.0+(2.0*vps/5.339)**2)))
        rmpb = 1.0
        if (vnt > 0.) then
            ab = 0.1612+sqrt((0.8388)**2+(0.1117*vnt)**2)
            bb = 0.1612+sqrt(0.8388**2+(0.1274*vnt)**2)
            rmpb = 0.5*(ab**7+bb**5)*exp(2.398*(1.0-sqrt(1.0+(vnt/2.398)**2)))
        end if
        rmp = min(rmpa, rmpb)

        eps_n = Qn*T98*rmn
        eps_p = Qp*T98*rmp
        eps = Qn*T98*rmn + Qp*T98*rmp
    end subroutine mUrca

    subroutine dUrca(nn,np,T9,vps,vns,vnt,eps)
    ! direct Urca
        real(dp), intent(in) :: nn, np, T9, vps, vns, vnt
        real(dp), intent(out) :: eps
        real(dp), parameter :: Q = 1.0e27
        real(dp) :: T96, rda, rdb, rd

        T96 = T9**6
        rda = 1.0_dp
        if(vps > 0.0_dp)  &
            & rda = (0.2312 + sqrt((0.7688)**2 + (0.1438*vps)**2))**5.5 &
            & *exp(3.427*(1.0-sqrt(1.0+(vps/3.427)**2)))
        rdb = 1.0_dp
        if(vnt > 0.0_dp) &
            & rdb = (0.2546 + sqrt((0.7454)**2 + (0.1284*vnt)**2))**5 &
            & *exp(2.701*(1.0-sqrt(1.0+(vnt/2.701)**2)))
        rd = min(rda,rdb)

        eps = Q*T96*rd
    end subroutine dUrca

    subroutine nupbf(nn,np,T9,vps,vns,vnt,eps,eps_n,eps_p)
        real(dp), intent(in) :: nn,np,T9,vps,vns,vnt
        real(dp), intent(out) :: eps, eps_n, eps_p
        real(dp), parameter :: Q = 1.170e21_dp*3.0, a_cns=1.0, a_cnt=3.18
        real(dp) :: T97
        real(dp) :: n, x, xFn, xFp, mn, mp, fa_n, fa_ns, fa_nt, fa_p, a_cp, pFn2, PFp2, vn2, vp2, v2

        n = nn + np
        x = np/n
        T97 = T9**7

        call effective_masses(n,x,mn,mp)
        mn = mn/Mn_n
        mp = mp/Mp_n

        ! proton factor
        fa_p = 0.0_dp
        if (vps > 0.0_dp) then
            v2 = vps**2
            fa_p = (0.602*v2 + 0.5942*v2**2 + 0.288*v2**3)*sqrt(0.5547+sqrt(0.4453**2+0.0113*v2)) &
                & *exp(-sqrt(4.0*v2+2.245**2)+2.245)
        end if

        ! neutron singlet
        fa_ns = 0.0_dp
        if (vns > 0.0_dp) then
            v2 = vns**2
            fa_ns = (0.602*v2 + 0.5942*v2**2 + 0.288*v2**3)*sqrt(0.5547+sqrt(0.4453**2+0.0113*v2)) &
                & *exp(-sqrt(4.0*v2+2.245**2)+2.245)
        end if

        ! neutron triplet (only case B for now)
        fa_nt = 0.0_dp
        if (vnt > 0.0_dp) then
            v2 = vnt**2
            fa_nt = (1.204*v2+3.733*v2**2+0.3191*v2**3)/(1.0+0.3511*v2)*(0.7591+sqrt(0.2409**2+0.3145*v2))**2* &
                & exp(-sqrt(4.0*v2+0.4616**2)+0.4616)
        end if

        fa_n = fa_nt*a_cnt + fa_ns*a_cns

        ! v/c corrections
        xFn = threepithird*nn**one_third * hbarc_n/Mn_n
        xFp = threepithird*np**one_third * hbarc_n/Mp_n

        pFn2 = xFn**2
        pFp2 = xFp**2
        vn2 = pFn2/(1.0+pFn2)
        vp2 = pFp2/(1.0+pFp2)

        a_cp  = 0.0064 + 1.59*pFp2 * (mp**2 + 11.0/42.0)

        eps_n = Q*T97*(mn*xFn*3.0*fa_n*vn2 + mn*xFn*3.0*fa_nt)
        eps_p = Q*T97*(mp*xFp*3.0*fa_p*a_cp*vp2)

        eps = Q*T97*(mn*xFn*3.0*fa_n*vn2 + mn*xFn*3.0*fa_nt + mp*xFp*3.0*fa_p*a_cp*vp2)

    contains
    subroutine effective_masses(n,x, mn,mp)
        real(dp), parameter :: fm_to_cm = 1.0e-13_dp
        real(dp), parameter :: Mneutron = 1.674927351e-24_dp
        real(dp), parameter :: Mproton  = 1.672621777e-24_dp

        real(dp) :: hbarc_n, Mn_n, Mp_n
        real(dp), intent(in) :: n,x
        real(dp), intent(out) :: mn, mp
        ! following constants are from APR EOS
        real(dp), parameter ::  p3 = 89.8_dp   ! MeV fm^5^
        real(dp), parameter ::  p4 = 0.457_dp  ! fm^3^
        real(dp), parameter ::  p5 = -59.0_dp  ! MeV fm^5^
        real(dp) :: t1, t2, t3

        hbarc_n = hbar*clight/mev_to_ergs/fm_to_cm
        Mn_n = Mneutron*clight**2/mev_to_ergs
        Mp_n = Mproton*clight**2/mev_to_ergs

        t1 = n*exp(-p4*n)
        t2 = p3+p5*(1.0-x)
        t3 = p3+x*p5
        mn = 1.0/(1.0/Mn_n + 2.0*t1*t2/hbarc_n**2)
        mp = 1.0/(1.0/Mp_n + 2.0*t1*t3/hbarc_n**2)
    end subroutine effective_masses
    end subroutine nupbf

end module eval_core_neutrino


      subroutine runP_iiii(k,i1,i2,i3,i4,f,Gr,Shat5,N0)
      implicit none
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,k,i1,i2,i3,i4,np
      parameter(np=3)
      double precision f(np),Gr(np,np)
      double complex Shat5(np,z4max,-2:0)

      do ep=-2,0
      Dv(diiii(z4(i1,i2,i3,i4))+N0,ep)=
     . (Shat5(k,z4(i1,i2,i3,i4),ep)
     . -2d0*delta(k,i1)*Dv(dzziii(z3(i2,i3,i4))+N0,ep)
     . -2d0*delta(k,i2)*Dv(dzziii(z3(i1,i3,i4))+N0,ep)
     . -2d0*delta(k,i3)*Dv(dzziii(z3(i1,i2,i4))+N0,ep)
     . -2d0*delta(k,i4)*Dv(dzziii(z3(i1,i2,i3))+N0,ep)
     . -Gr(k,1)*Dv(diiiii(z5(1,i1,i2,i3,i4))+N0,ep)
     . -Gr(k,2)*Dv(diiiii(z5(2,i1,i2,i3,i4))+N0,ep)
     . -Gr(k,3)*Dv(diiiii(z5(3,i1,i2,i3,i4))+N0,ep))/f(k)
      enddo

      return
      end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C   FFTPACK 5.0
C
C   Authors:  Paul N. Swarztrauber and Richard A. Valent
C
C   $Id$
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE R1F3KF (IDO,L1,CC,IN1,CH,IN2,WA1,WA2)
      REAL       CH(IN2,IDO,3,L1)  ,CC(IN1,IDO,L1,3)     ,
     1                WA1(IDO)     ,WA2(IDO)
C
      ARG=2.*4.*ATAN(1.0)/3.
      TAUR=COS(ARG)
      TAUI=SIN(ARG)
      DO 101 K=1,L1
         CH(1,1,1,K) = CC(1,1,K,1)+(CC(1,1,K,2)+CC(1,1,K,3))
         CH(1,1,3,K) = TAUI*(CC(1,1,K,3)-CC(1,1,K,2))
         CH(1,IDO,2,K) = CC(1,1,K,1)+TAUR*
     1      (CC(1,1,K,2)+CC(1,1,K,3))
  101 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IDP2 = IDO+2
      DO 103 K=1,L1
         DO 102 I=3,IDO,2
            IC = IDP2-I
            CH(1,I-1,1,K) = CC(1,I-1,K,1)+((WA1(I-2)*CC(1,I-1,K,2)+
     1       WA1(I-1)*CC(1,I,K,2))+(WA2(I-2)*CC(1,I-1,K,3)+WA2(I-1)*
     1       CC(1,I,K,3)))
            CH(1,I,1,K) = CC(1,I,K,1)+((WA1(I-2)*CC(1,I,K,2)-
     1       WA1(I-1)*CC(1,I-1,K,2))+(WA2(I-2)*CC(1,I,K,3)-WA2(I-1)*
     1       CC(1,I-1,K,3)))
            CH(1,I-1,3,K) = (CC(1,I-1,K,1)+TAUR*((WA1(I-2)*
     1       CC(1,I-1,K,2)+WA1(I-1)*CC(1,I,K,2))+(WA2(I-2)*
     1       CC(1,I-1,K,3)+WA2(I-1)*CC(1,I,K,3))))+(TAUI*((WA1(I-2)*
     1       CC(1,I,K,2)-WA1(I-1)*CC(1,I-1,K,2))-(WA2(I-2)*
     1       CC(1,I,K,3)-WA2(I-1)*CC(1,I-1,K,3))))
            CH(1,IC-1,2,K) = (CC(1,I-1,K,1)+TAUR*((WA1(I-2)*
     1       CC(1,I-1,K,2)+WA1(I-1)*CC(1,I,K,2))+(WA2(I-2)*
     1       CC(1,I-1,K,3)+WA2(I-1)*CC(1,I,K,3))))-(TAUI*((WA1(I-2)*
     1       CC(1,I,K,2)-WA1(I-1)*CC(1,I-1,K,2))-(WA2(I-2)*
     1       CC(1,I,K,3)-WA2(I-1)*CC(1,I-1,K,3))))
            CH(1,I,3,K) = (CC(1,I,K,1)+TAUR*((WA1(I-2)*CC(1,I,K,2)-
     1       WA1(I-1)*CC(1,I-1,K,2))+(WA2(I-2)*CC(1,I,K,3)-WA2(I-1)*
     1       CC(1,I-1,K,3))))+(TAUI*((WA2(I-2)*CC(1,I-1,K,3)+WA2(I-1)*
     1       CC(1,I,K,3))-(WA1(I-2)*CC(1,I-1,K,2)+WA1(I-1)*
     1       CC(1,I,K,2))))
            CH(1,IC,2,K) = (TAUI*((WA2(I-2)*CC(1,I-1,K,3)+WA2(I-1)*
     1       CC(1,I,K,3))-(WA1(I-2)*CC(1,I-1,K,2)+WA1(I-1)*
     1       CC(1,I,K,2))))-(CC(1,I,K,1)+TAUR*((WA1(I-2)*CC(1,I,K,2)-
     1       WA1(I-1)*CC(1,I-1,K,2))+(WA2(I-2)*CC(1,I,K,3)-WA2(I-1)*
     1       CC(1,I-1,K,3))))
  102    CONTINUE
  103 CONTINUE
      RETURN
      END


      DOUBLE PRECISION FUNCTION DT_DBETAR(Gam,Eta)

C***********************************************************************
C Sampling from Beta -distribution between 0.0 and 1.0                 *
C  F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
C Processed by S. Roesler, 6.5.95                                      *
C***********************************************************************

      IMPLICIT NONE
      DOUBLE PRECISION DT_DGAMRN , Eta , Gam , y , z
      SAVE

      y = DT_DGAMRN(1.0D0,Gam)
      z = DT_DGAMRN(1.0D0,Eta)
      DT_DBETAR = y/(y+z)

      END FUNCTION


program lorenz96
implicit none
!
! Small little Lorenz 96; Compile with ifort -assume byterecl -O3 -mkl (-heap-arrays)
!

!Model Technical Parameters
integer :: dimX
integer :: dimY !
integer :: dimF ! Total dimension
integer :: intscheme ! 1 ... Runge Kutta 4th order
integer :: inittype ! 1 ... random , 2 ... stationary+random perturb , 3... stationary , 4 restart, 5 start with certain initialstate (initialstate.dat), 6 use time given in spinup
integer :: tl! GS is activated
integer :: gin ! CLV computation is activated ** not implemented **
real(kind=8) :: dt! Timestep
integer :: samplerate  ! How often to write out
real(kind=8) :: timeint ! How long?
real(kind=8) :: remaining, elapsed
!Model Parameters
real(kind=8) :: F   ! Forcing to X Variables
real(kind=8) :: hx  !
real(kind=8) :: hy  !
real(kind=8) :: eps !
real(kind=8) :: c   !
real(kind=8) :: b   !

!Model Fields & Variables
real(kind=8),dimension(:), allocatable :: x,xnew,k1,k2,k3,k4,xold,tau,lyapunov,loclyap
real(kind=8),dimension(:,:), allocatable :: tanglin,tanglinnew,tanglinold,one,blv,clv,clvout
real(kind=8) :: ky,dnrm2, clock_rate,powerx1,powerx2,powerx3,powerx4
real(kind=8) :: restartint !restart interval
real(kind=8) :: spinup ! spinup time if inittype is 6
integer :: restartintstep ! how often write restart file in samplerate steps
integer :: n_field ! How many fields are being calculated (x(0),x(1),...,x(n)) ==> n_field==n+1
integer :: istep ! Step number?
integer :: initialentry ! initial timestep
integer :: saveswitch ! save tl results
integer :: ensemble ! number of ensembles
integer ::fileID = 0 , ens
integer :: lwork,ilaenv,info,i,lastentry,j,t1,t2,clock_max,samplerate_re,istep_initial,correlationtend
real(kind=8),dimension(:),allocatable :: work,workc,meanlyap
real(kind=8) :: cm1,cm2,cm3,cm4,meanx,variance,kurtosis,skewness
character(len=20) :: str

!
! The namelist reads in all parameters of both versions of the Lorenz96
!
namelist/lorenz96nl/dimX,dimY,intscheme,inittype,spinup,restartint,tl,gin,dt,samplerate,timeint,F,hx,hy,eps,c,b,saveswitch,correlationtend,ensemble
read (*,lorenz96nl,end=991)
991  continue

! total dimension of model phase space
dimF = dimX+dimX*dimY
if (gin.eq.1 .and. tl.ne.1) then; write(*,*) 'CLV is on but tangent linear is off: Error.';end if

!
! Allocate
!

allocate(x(dimF),xnew(dimF),k1(dimF),k2(dimF),k3(dimF),k4(dimF),xold(dimF),tau(dimF),lyapunov(dimF),loclyap(dimF))
if (tl.eq.1) then
  allocate(tanglin(dimF,dimF),tanglinnew(dimF,dimF),tanglinold(dimF,dimF),one(dimF,dimF),blv(dimF,dimF),meanlyap(dimF))
endif
if (gin.eq.1) then
allocate(clv(dimF,dimF),clvout(dimF,dimF),workc(dimF))
endif

!
! Prepare Ensemble runs
!
if (ensemble.gt.1) then
   do i=1,ensemble
      !
      ! Open Files
      !
      call system(trim(adjustl("mkdir ensemble"//str(i))))
      if (inittype.eq.4) then
	open(unit=9+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//"/quickoutput.log",form="formatted",status="old") ! Quick Output
	open(unit=10+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//"/restart.dat",form='unformatted',access='direct',recl=8*dimF)  ! Restart file
	open(unit=11+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//'initialstate.dat',form='unformatted',access='direct',recl=8*dimF,status='old')  ! Initial state

	open(unit=1+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//"/lorenz96field.dat",form="unformatted",status="old",access="direct",recl=8*dimF) ! Field
	if (tl.eq.1) then
	  open(unit=2+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//"/lorenz96propagator.dat",form="unformatted",status="old",access="direct",recl=8*dimF**2) ! Propagator
	  open(unit=3+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//"/lorenz96blvlyap.dat",form="unformatted",status="old",access="direct",recl=8*dimF) ! BLV local lyap
	  open(unit=4+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//"/lorenz96blv.dat",form="unformatted",status="old",access="direct",recl=8*(dimF**2+dimF)) ! BLV Field
	  open(unit=7+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//"/lorenz96meanlyap.dat",form="formatted",status="old") ! CLV lyap
	  if (gin.eq.1) then
	    if (correlationtend.eq.1) then
	      open(unit=13+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//"/corrtend.dat",form="unformatted",status="old",access="direct",recl=8*(2*dimF-1))
	    endif
	    open(unit=6+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//"/lorenz96clv.dat",form="unformatted",status="old",access="direct",recl=8*(dimF**2)) ! CLV Field
	    open(unit=5+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//"/lorenz96clvlyap.dat",form="unformatted",status="old",access="direct",recl=8*dimF) ! CLV local lyap
	  end if
	end if
      elseif (inittype.eq.5) then

	open(unit=9+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//"/quickoutput.log",form="formatted",status="replace") ! Quick Output
	open(unit=10+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//'restart.dat',form='unformatted',access='direct',recl=8*dimF,status='replace')  ! Restart file
	open(unit=11+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//'initialstate.dat',form='unformatted',access='direct',recl=8*dimF,status='old')  ! Initial state

	open(unit=1+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//"/lorenz96field.dat",form="unformatted",status="replace",access="direct",recl=8*dimF) ! Field
	if (tl.eq.1) then
	  open(unit=2+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//"/lorenz96propagator.dat",form="unformatted",status="replace",access="direct",recl=8*dimF**2) ! Propagator
	  open(unit=3+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//"/lorenz96blvlyap.dat",form="unformatted",status="replace",access="direct",recl=8*dimF) ! BLV local lyap
	  open(unit=4+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//"/lorenz96blv.dat",form="unformatted",status="replace",access="direct",recl=8*(dimF**2+dimF)) ! BLV Field
	  open(unit=7+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//"/lorenz96meanlyap.dat",form="formatted",status="replace") ! CLV lyap
	  if (gin.eq.1) then
	    if (correlationtend.eq.1) then
	      open(unit=13+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//"/corrtend.dat",form="unformatted",status="replace",access="direct",recl=8*(2*dimF-1))
	    endif
	    open(unit=6+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//"/lorenz96clv.dat",form="unformatted",status="replace",access="direct",recl=8*(dimF**2)) ! CLV Field
	    open(unit=5+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//"/lorenz96clvlyap.dat",form="unformatted",status="replace",access="direct",recl=8*dimF) ! CLV local lyap
	  end if
	end if
      else

	open(unit=9+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//"/quickoutput.log",form="formatted",status="replace") ! Quick Output
	open(unit=10+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//'restart.dat',form='unformatted',access='direct',recl=8*dimF,status="replace")  ! Restart file
	open(unit=11+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//'initialstate.dat',form='unformatted',access='direct',recl=8*dimF,status="replace")  ! Initial state

	open(unit=1+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//"/lorenz96field.dat",form="unformatted",status="replace",access="direct",recl=8*dimF) ! Field
	if (tl.eq.1) then
	  open(unit=2+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//"/lorenz96propagator.dat",form="unformatted",status="replace",access="direct",recl=8*dimF**2) ! Propagator
	  open(unit=3+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//"/lorenz96blvlyap.dat",form="unformatted",status="replace",access="direct",recl=8*dimF) ! BLV local lyap
	  open(unit=4+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//"/lorenz96blv.dat",form="unformatted",status="replace",access="direct",recl=8*(dimF**2+dimF)) ! BLV Field
	  open(unit=7+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//"/lorenz96meanlyap.dat",form="formatted",status="replace") ! CLV lyap
	  if (gin.eq.1) then
	    if (correlationtend.eq.1) then
	      open(unit=13+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//"/corrtend.dat",form="unformatted",status="replace",access="direct",recl=8*(2*dimF-1))
	    endif
	    open(unit=6+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//"/lorenz96clv.dat",form="unformatted",status="replace",access="direct",recl=8*(dimF**2)) ! CLV Field
	    open(unit=5+1000+100*i,file=trim(adjustl("ensemble"//str(i)))//"/lorenz96clvlyap.dat",form="unformatted",status="replace",access="direct",recl=8*dimF) ! CLV local lyap
	  end if
	end if
      endif

   end do

else

    !
    ! Open Files  (no ensemble)
    !

    if (inittype.eq.4) then
      open(unit=9+1100,file="quickoutput.log",form="formatted",status="old") ! Quick Output
      open(unit=10+1100,file='restart.dat',form='unformatted',access='direct',recl=8*dimF)  ! Restart file
      open(unit=11+1100,file='initialstate.dat',form='unformatted',access='direct',recl=8*dimF,status='old')  ! Initial state

      open(unit=1+1100,file="lorenz96field.dat",form="unformatted",status="old",access="direct",recl=8*dimF) ! Field
      if (tl.eq.1) then
	open(unit=2+1100,file="lorenz96propagator.dat",form="unformatted",status="old",access="direct",recl=8*dimF**2) ! Propagator
	open(unit=3+1100,file="lorenz96blvlyap.dat",form="unformatted",status="old",access="direct",recl=8*dimF) ! BLV local lyap
	open(unit=4+1100,file="lorenz96blv.dat",form="unformatted",status="old",access="direct",recl=8*(dimF**2+dimF)) ! BLV Field
	open(unit=7+1100,file="lorenz96meanlyap.dat",form="formatted",status="old") ! CLV lyap
	if (gin.eq.1) then
	  if (correlationtend.eq.1) then
	    open(unit=13+1100,file="corrtend.dat",form="unformatted",status="old",access="direct",recl=8*(2*dimF-1))
	  endif
	  open(unit=6+1100,file="lorenz96clv.dat",form="unformatted",status="old",access="direct",recl=8*(dimF**2)) ! CLV Field
	  open(unit=5+1100,file="lorenz96clvlyap.dat",form="unformatted",status="old",access="direct",recl=8*dimF) ! CLV local lyap
	end if
      end if
    elseif (inittype.eq.5) then

      open(unit=9+1100,file="quickoutput.log",form="formatted",status="replace") ! Quick Output
      open(unit=10+1100,file='restart.dat',form='unformatted',access='direct',recl=8*dimF,status='replace')  ! Restart file
      open(unit=11+1100,file='initialstate.dat',form='unformatted',access='direct',recl=8*dimF,status='old')  ! Initial state

      open(unit=1+1100,file="lorenz96field.dat",form="unformatted",status="replace",access="direct",recl=8*dimF) ! Field
      if (tl.eq.1) then
	open(unit=2+1100,file="lorenz96propagator.dat",form="unformatted",status="replace",access="direct",recl=8*dimF**2) ! Propagator
	open(unit=3+1100,file="lorenz96blvlyap.dat",form="unformatted",status="replace",access="direct",recl=8*dimF) ! BLV local lyap
	open(unit=4+1100,file="lorenz96blv.dat",form="unformatted",status="replace",access="direct",recl=8*(dimF**2+dimF)) ! BLV Field
	open(unit=7+1100,file="lorenz96meanlyap.dat",form="formatted",status="replace") ! CLV lyap
	if (gin.eq.1) then
	  if (correlationtend.eq.1) then
	    open(unit=13+1100,file="corrtend.dat",form="unformatted",status="replace",access="direct",recl=8*(2*dimF-1))
	  endif
	  open(unit=6+1100,file="lorenz96clv.dat",form="unformatted",status="replace",access="direct",recl=8*(dimF**2)) ! CLV Field
	  open(unit=5+1100,file="lorenz96clvlyap.dat",form="unformatted",status="replace",access="direct",recl=8*dimF) ! CLV local lyap
	end if
      end if
    else

      open(unit=9+1100,file="quickoutput.log",form="formatted",status="replace") ! Quick Output
      open(unit=10+1100,file='restart.dat',form='unformatted',access='direct',recl=8*dimF,status="replace")  ! Restart file
      open(unit=11+1100,file='initialstate.dat',form='unformatted',access='direct',recl=8*dimF,status="replace")  ! Initial state

      open(unit=1+1100,file="lorenz96field.dat",form="unformatted",status="replace",access="direct",recl=8*dimF) ! Field
      if (tl.eq.1) then
	open(unit=2+1100,file="lorenz96propagator.dat",form="unformatted",status="replace",access="direct",recl=8*dimF**2) ! Propagator
	open(unit=3+1100,file="lorenz96blvlyap.dat",form="unformatted",status="replace",access="direct",recl=8*dimF) ! BLV local lyap
	open(unit=4+1100,file="lorenz96blv.dat",form="unformatted",status="replace",access="direct",recl=8*(dimF**2+dimF)) ! BLV Field
	open(unit=7+1100,file="lorenz96meanlyap.dat",form="formatted",status="replace") ! CLV lyap
	if (gin.eq.1) then
	  if (correlationtend.eq.1) then
	    open(unit=13+1100,file="corrtend.dat",form="unformatted",status="replace",access="direct",recl=8*(2*dimF-1))
	  endif
	  open(unit=6+1100,file="lorenz96clv.dat",form="unformatted",status="replace",access="direct",recl=8*(dimF**2)) ! CLV Field
	  open(unit=5+1100,file="lorenz96clvlyap.dat",form="unformatted",status="replace",access="direct",recl=8*dimF) ! CLV local lyap
	end if
      end if
    endif

endif

!
! Allocate some stuff for qr
!
if (tl.eq.1) then
    lwork=ilaenv(1,"dgeqrf"," ",dimF,dimF,dimF,-1)
    lwork=dimF*lwork
    allocate(work(lwork))
endif

!$OMP PARALLEL DO DEFAULT(Private) Shared(dimF,dimX,dimY,intscheme,inittype,spinup,restartint,tl,gin,dt,samplerate,timeint,F,hx,hy,eps,c,b,saveswitch,correlationtend,ensemble,initialentry,n_field,lwork,samplerate_re)

do ens=1,ensemble
    fileid=1000+100*ens
    !
    ! Initialization
    !

    write(*,'(''Initialization'')')

    !
    ! Init Statistics
    !

    if (inittype.eq.4) then
      read(10+fileID,rec=7) powerx1,powerx2,powerx3,powerx4
    else
      powerx1=0.0d0
      powerx2=0.0d0
      powerx3=0.0d0
      powerx4=0.0d0
    endif

    i=0
    call initialize(x,lyapunov,initialentry,samplerate_re,spinup,F,hx,hy,eps,c,b,dt,inittype,dimX,dimY,dimF,fileID)

    ! Save initial state

    if (inittype.ne.4) then
      write(11+fileID,rec=1) x
      close(11+fileID)
    else
      close(11+fileID)
    endif
    ! Compue integration length in time steps

    n_field=floor(dble(timeint)/dble(dt))+1! +(initialentry-1)*samplerate

    ! Restart in samplerate intervalls

    restartintstep=floor(dble(restartint)/dble(dt)/dble(samplerate))

    ! Put timestep counter to initial value

    if (inittype.eq.4) then
      istep_initial=initialentry*samplerate_re+1
    else
      istep_initial=1
    endif

    ! Save model parameters in restart file
    write(*,*) (i+fileID,i=1,11)
    write(10+fileID,rec=4) dimX,dimY,intscheme,inittype,tl,gin,dt
    write(10+fileID,rec=5) samplerate,timeint,F,hx
    write(10+fileID,rec=6) hy,eps,c,b

    !
    ! Reserve Disk Space for clv and blv and trajectory computation
    !

    if (inittype.ne.4) then
      if (tl.eq.1) then
	!write(2+fileID,rec=floor(dble(n_field)/dble(samplerate))) -99
	write(3+fileID,rec=floor(dble(n_field)/dble(samplerate))) -99
	write(4+fileID,rec=floor(dble(n_field)/dble(samplerate))) -99
	if (gin.eq.1) then
	  write(6+fileID,rec=floor(dble(n_field)/dble(samplerate))) -99
	  write(5+fileID,rec=floor(dble(n_field)/dble(samplerate))) -99
	end if
      end if
    endif

    !
    ! Create Orthogonal random matrix for qr forward steps or load from restart (if tl is 1)
    !

    if (tl.eq.1) then
      if (inittype.eq.4) then
	tanglinold(:,:)=one(:,:)
	call dlaset('',dimF,dimF, 0.0d0, 1.0d0, one, dimF)
	xold=x
	read(4,rec=initialentry) blv,tau
	tanglinold(:,:)=one(:,:)
      else
	call dlaset('',dimF,dimF, 0.0d0, 1.0d0, one, dimF)
	xold=x
	lyapunov=0.0d0
	call random_number(blv)
	call dgeqrf(dimF,dimF,blv,dimF, tau, work, lwork, info)
	tanglinold(:,:)=one(:,:)

      endif
    end if

    !
    ! Start Integration
    !

    xold=x
    call write_out_notl(xold,initialentry,fileID,dimX,dimY,dimF)
    write(*,'(''Model Parameters:'')')

    call write_model_parameters(dimX,dimY,intscheme,inittype,spinup,tl,gin,dt,samplerate,timeint,F,hx,hy,eps,c,b,fileID)

    write(*,'(''Start Forward Integration:'')')
    write(*,'(''Progress so far:'')')
    call system_clock ( t1, clock_rate, clock_max )

    do istep=istep_initial+1,n_field
      !write(*,*) istep/samplerate,dble(istep)/(dble(n_field))
      powerx1=powerx1+sum(x(1:dimX))/dble(dimX)/dble(n_field)
      powerx2=powerx2+sum(x(1:dimX)**2.0d0)/dble(dimX)/dble(n_field)
      powerx3=powerx3+sum(x(1:dimX)**3.0d0)/dble(dimX)/dble(n_field)
      powerx4=powerx4+sum(x(1:dimX)**4.0d0)/dble(dimX)/dble(n_field)
      !	(*,*) powerx1,dble(dimX),dble(n_field)
      if (mod(istep,floor(dble(n_field)/1.0d0)).eq.0) then
	  call system_clock ( t2, clock_rate, clock_max )
	  call progress(floor(dble(istep)/dble(n_field/10.0d0))+1)
	  elapsed=real ( t2 - t1 ) / real ( clock_rate )
	  remaining=elapsed/(floor(dble(istep)/dble(n_field/10.0d0))+1)*(10-(floor(dble(istep)/dble(n_field/10.0d0))+1))
	  write ( *, '(''Elapsed time             = '',F15.2,'' sec ('',F6.2,'' min) ('',F6.2,'' hours)'')') elapsed,elapsed/real(60),elapsed/real(3600)
	  write ( *, '(''Estimated remaining time = '',F15.2,'' sec ('',F6.2,'' min) ('',F6.2,'' hours)'')') remaining,remaining/real(60),remaining/real(3600)

      end if;

      if (tl.eq.1) then
	!
	! tangent linear is activated
	!
	call runge_kutta_4th(xnew,x,k1,k2,k3,k4,F,hx,hy,eps,c,b,dt,dimX,dimY,dimF)
	call rungekutta4thtl(tanglinnew,x,k1,k2,k3,k4,F,hx,hy,eps,c,b,dt,dimX,dimY,dimF)
	call dgemm ('n', 'n', dimF, dimF, dimF, 1.0d0, tanglinnew, dimF,tanglinold, dimF,0.0d0, tanglin, dimF)
	if (mod(istep-1,samplerate).eq.0) then
	  i=i+1
	  if (saveswitch.eq.1) then
	    call write_out(xold,tanglin,(istep-1)/samplerate,fileID,dimX,dimY,dimF)
	  endif
	  !write(*,*) istep_initial,istep,(istep-1)/samplerate,loclyap
	  call qr(tanglin,blv,tau,lyapunov,loclyap,samplerate,dt,(istep-1)/samplerate,fileID,dimF,lwork,saveswitch); ! lyapunov only adds up local rates; no average is done
	  meanlyap=lyapunov/dble((istep-1)/samplerate)

	  !
	  ! Write Quickoutput to quickoutput.log
	  !
	  write(9+fileID,'(''Quick Output:'')')
	  write(9+fileID,'(''   Timestep [in MTU]:'',F15.2,''; x(1)'',E10.2)')(istep-1)*dt,x(1)
	  if (dimY>0) then; write(9,'(''y(1,1): '',E10.2)') x(dimX+1); end if
	  write(9+fileID,*) '    lyap(1): ',meanlyap(1),'loclyap(1): ',loclyap(1)
	  write(9+fileID,*) '    lyap(2): ',meanlyap(2),'loclyap(2): ',loclyap(2)
	  write(9+fileID,*) '    KY: ',ky(meanlyap,dimF)
	  !keep track of steps in samplerates
	  lastentry=(istep-1)/samplerate
	  tanglin(:,:)=one(:,:)
	  xold=xnew
	  !write(*,*) (istep-1)/samplerate,restartintstep,mod((istep-1)/samplerate,restartintstep)
	  if (mod((istep-1)/samplerate,restartintstep).eq.0) then
	    !
	    ! Write restart file
	    !
	    write(*,*) 'Restart file saved; ',lastentry
	    write(10+fileID,rec=1) xold
	    write(10+fileID,rec=2) lastentry
	    write(10+fileID,rec=3) lyapunov
	    write(10+fileID,rec=7) powerx1,powerx2,powerx3,powerx4
	  endif
	end if
	tanglinold=tanglin

      else
	! no tangent linear
	call runge_kutta_4th(xnew,x,k1,k2,k3,k4,F,hx,hy,eps,c,b,dt,dimX,dimY,dimF)
	!compute statistics

	if (mod(istep-1,samplerate).eq.0) then
	i=i+1
	!  write(*,*) 'ti',(istep-1)*dt,'x(1)',x(1),'y(1,1)',x(dimX+1)
	write(9+fileID,'(''Quick Output:'')')
	write(9+fileID,'(''     Timestep [in MTU]:'',F15.2,''; x(1)'',E10.2)') (istep-1)*dt,x(1)

	if (dimY>0) then; write(9,'(''y(1,1): '',E10.2)') x(dimX+1); end if
	if (saveswitch.eq.1) then
	    call write_out_notl(xold,(istep-1)/samplerate,fileID,dimX,dimY,dimF)
	endif
	lastentry=(istep-1)/samplerate
	xold=xnew
	  if (mod((istep-1)/samplerate,restartintstep).eq.0) then
	    !
	    ! Write restart file
	    !
	    write(*,*) 'Restart file saved; ',lastentry
	    write(10+fileID,rec=1) xold
	    write(10+fileID,rec=2) lastentry
	    write(10+fileID,rec=7) powerx1,powerx2,powerx3,powerx4
	  endif
	end if

      end if

      x=xnew
    end do
    !write(*,'(''Final State:'')')
    !write(*,*) x
    !
    ! Write restart file
    !
    write(10+fileID,rec=1) x
    write(10+fileID,rec=2) lastentry
    if (tl.eq.1) then
      write(10+fileID,rec=3) meanlyap
    endif

    if (tl.eq.1) then
      write(9+fileID,'(''lyap('',i3,''): '',E15.3)') (i,meanlyap(i),i=1,dimX)
      write(7+fileID,'(E20.10)') meanlyap
      !write(*,'(E15.3)') meanlyap
    endif

    !
    ! Compute statistics
    !

    cm1=powerx1
    cm2=powerx2-powerx1**2.0d0
    cm3=powerx3-3.0d0*powerx2*powerx1+2*powerx1**3.0d0
    cm4=powerx4-4.0d0*powerx3*powerx1+6.0d0*powerx2*powerx1**2.0d0-3.0d0*powerx1**4.0d0

    meanx=powerx1
    variance=(powerx2-powerx1**2.0d0)
    skewness=cm3/cm2**(1.5d0)
    kurtosis=cm4/cm2**2.0d0 -3.0d0

    open(unit=8+fileID,file='powers_of_x.dat',form='formatted')
    write(8+fileID,'(4E20.10)') powerx1,powerx2,powerx3,powerx4
    write(8+fileID,'(4E20.10)') cm1,cm2,cm3,cm4
    write(8+fileID,'(4E20.10)') meanx,variance,skewness,kurtosis
    close(8+fileID)

    write(*,'(''Statistics of X modes (powers_of_x.dat):'')')
    write(*,'(''<x>         = '',F20.10)') powerx1
    write(*,'(''<x^2>       = '',F20.10)') powerx2
    write(*,'(''<x^3>       = '',F20.10)') powerx3
    write(*,'(''<x^4>       = '',F20.10)') powerx4
    write(*,'(''<x>         = '',F20.10)') cm1
    write(*,'(''<(x-<x>)^2> = '',F20.10)') cm2
    write(*,'(''<(x-<x>)^3> = '',F20.10)') cm3
    write(*,'(''<(x-<x>)^4> = '',F20.10)') cm4
    write(*,'(''Mean        : '',F20.10)') meanx
    write(*,'(''Variance    : '',F20.10)') variance
    write(*,'(''Skewness    : '',F20.10)') skewness
    write(*,'(''Kurtosis    : '',F20.10)') kurtosis

    if (gin.eq.1) then
    !
    ! Initialize Ginelli
    !
      write(9+fileID,'(''Start Ginelli Backward'')')
      lyapunov=0.0d0
      call random_number(clv)
      call dgeqrf(dimF,dimF,clv,dimF, tau, work, lwork, info)
      do i=1,dimF-1
	clv(i+1:dimF,i)=0.0d0
      enddo

      call system_clock ( t1, clock_rate, clock_max )
      tanglin=0.0d0
      read(4+fileID,rec=lastentry) tanglin,tau
      i=0
      do istep=lastentry,2,-1
	i=i+1;
	!
	! Show progress and estiamte remaining time
	!
	if (mod(lastentry-istep+1,ceiling(dble(lastentry-1)/10.0d0)).eq.0) then
	  call system_clock ( t2, clock_rate, clock_max )
	  call progress(ceiling(dble(lastentry-istep+1)/dble((lastentry-1)/10.0d0))+1)
	  elapsed=real ( t2 - t1 ) / real ( clock_rate )
	  remaining=elapsed/(ceiling(dble(lastentry-istep+1)/dble((lastentry-1)/10.0d0))+1)*(10-(ceiling(dble(lastentry-istep+1)/dble((lastentry-1)/10.0d0))+1))
	  write ( *, '(''Elapsed time             = '',F15.2,'' sec ('',F6.2,'' min) ('',F6.2,'' hours)'')') elapsed,elapsed/real(60),elapsed/real(3600)
	  write ( *, '(''Estimated remaining time = '',F15.2,'' sec ('',F6.2,'' min) ('',F6.2,'' hours)'')') remaining,remaining/real(60),remaining/real(3600)

	end if;
	!
	! Leave only upper triangular matrix (Propagatot in BLV basis)
	!
	do i=1,dimF-1
	  tanglin(i+1:dimF,i)=0.0d0
	enddo
	!
	! Invert this equation R C_i=C_i+1
	!
	call dtrtrs('u', 'n', 'n', dimF, dimF, tanglin, dimF, clv, dimF, info);
	!
	! renormalize and store covariant LEs
	!
	do j=1,dimF
	loclyap(j)=1.0d0/dnrm2(dimF,clv(1:dimF,j),1)
	clv(1:dimF,j)=clv(1:dimF,j)*loclyap(j)
	end do
	loclyap=log(abs(loclyap))
	write(5+fileID,rec=istep) loclyap
	lyapunov=lyapunov+loclyap
	meanlyap=lyapunov/dble(i)
	write(9+fileID,*) '  Time:',(istep-1)*dt,'clv(1,1)',clv(1,1)
	write(9+fileID,*) '  lyap(1)',meanlyap(1),'loclyap(1)',loclyap(1)
	write(9+fileID,*) '  KY',ky(meanlyap,dimF)
	read(4+fileID,rec=istep-1) blv,tau
	clvout=clv
	!
	! Get CLVs in euclidean standard basis (inGinelli they are obtained in BLV basis)
	!
	call dorm2r( "l", "n", dimF, dimF, dimF, blv, dimF, tau, clvout,dimF, workc, info );
	if (correlationtend.eq.1) then
	  call testcorrelation(istep,clvout,F,hx,hy,eps,c,b,dt,dimX,dimY,dimF,fileID)
	endif
	write(6+fileID,rec=istep) clvout
	tanglin=blv
      enddo

    end if

end do
!$OMP END PARALLEL DO
stop
end program lorenz96

subroutine testcorrelation(istep,clvout,F,hx,hy,eps,c,b,dt,dimX,dimY,dimF,fileID)
implicit none
integer :: istep,dimF,dimX,dimY,i,fileID
real(kind=8) :: F,hx,hy,eps,c,b,dt
real(kind=8), dimension(dimF,dimF) :: clvout
real(kind=8), dimension(dimF,dimF-1) :: ortho1,ortho2
real(kind=8), dimension(dimF) :: x,tend,k1,k2,k3,k4

tend=0.0d0
read(1+fileID,rec=istep) x
call runge_kutta_4th(tend,x,k1,k2,k3,k4,F,hx,hy,eps,c,b,dt,dimX,dimY,dimF)
tend=(tend-x)
tend=tend/sqrt(sum(tend**2.0d0))

call dgemv ('t', dimF, dimF, 1.0d0, clvout, dimF, tend, 1, 0.0d0, k3, 1)

ortho1=clvout(:,1:dimF-1)
do i=2,dimF
  ortho2(:,i-1)=clvout(:,i)-sum(ortho1(:,i-1)*clvout(:,i))*ortho1(:,i-1)
  ortho2(:,i-1)=ortho2(:,i-1)/sum(ortho2(:,i-1)**2.0d0)
enddo
call dgemv ('t', dimF, dimF-1, 1.0d0, ortho1, dimF, tend, 1, 0.0d0, k1(1:dimF-1), 1)
call dgemv ('t', dimF, dimF-1, 1.0d0, ortho2, dimF, tend, 1, 0.0d0, k2(1:dimF-1), 1)
write(13+fileID,rec=istep) k3,sqrt(k1(1:dimF-1)**2.0d0+k2(1:dimF-1)**2.0d0)
end

subroutine initialize(x0,lyapunov,initialentry,samplerate_re,spinup,F,hx,hy,eps,c,b,dt,inittype,dimX,dimY,dimF,fileID)
implicit none
integer :: dimX,dimY,dimF,inittype,istep,initialentry
integer :: dimX_re,dimY_re,intscheme_re,inittype_re,tl_re,gin_re,samplerate_re
integer :: fileID
real(kind=8) :: dt_re,timeint_re,F_re,hx_re,hy_re,eps_re,c_re,b_re
real(kind=8),dimension(dimF) :: x0,xnew,lyapunov
real(kind=8) :: spinup,F,hx,hy,eps,c,b,dt,spinup_re
real :: seed
real(kind=8),dimension(dimF,dimF) :: k1,k2,k3,k4
call init_random_seed()         ! see example of RANDOM_SEED
x0=0.0d0
if (inittype.eq.1) then
! Random
  write(*,'(''Random'')')
  CALL random_number(x0)
  initialentry=1
  lyapunov=0.0d0
else if (inittype.eq.2) then
  CALL random_number(x0);write(*,*) x0(1)
  write(*,'(''Stationary + Perturb - not correct right now'')')
  x0(1:dimX)=F/(1.0d0+(hx/b)**2.0d0*c*dble(dimY)) +x0(1:dimX)
  x0(dimX+1:dimF)=hy/b*F/(1.0d0+(hy/b)**2.0d0*c*dble(dimY)) +x0(1+dimX:dimF)
  initialentry=1
  lyapunov=0.0d0
else if (inittype.eq.3) then
  write(*,'(''Stationary - not correct right now'')')
  x0(1:dimX)=F/(1.0d0+(hx/b)**2.0d0*c*dble(dimY))
  x0(dimX+1:dimF)=hy/b*F/(1.0d0+(hy/b)**2.0d0*c*dble(dimY))
  initialentry=1
  lyapunov=0.0d0
else if (inittype.eq.4) then
  write(*,'(''Load Restart file'')')
  read(10,rec=1) x0
  write(*,'(''x0(1): '',E20.10)') x0(1)
  read(10,rec=2) initialentry
  read(10,rec=3) lyapunov
  read(10,rec=4) dimX_re,dimY_re,intscheme_re,inittype_re,spinup_re,tl_re,gin_re,dt_re
  read(10,rec=5) samplerate_re,timeint_re,F_re,hx_re
  read(10,rec=6) hy_re,eps_re,c_re,b_re
  write(*,*) lyapunov
  !initialentry=initialentry*samplerate_re+1
  write(*,'(''Model Parameters before restart: '')')
  call write_model_parameters(dimX_re,dimY_re,intscheme_re,inittype_re,spinup_re,tl_re,gin_re,dt_re,samplerate_re,timeint_re,F_re,hx_re,hy_re,eps_re,c_re,b_re,fileID)
else if (inittype.eq.5) then
  write(*,'(''Load Initial State - no restart!'')')
  read(11,rec=1) x0
  initialentry=1
  lyapunov=0.0d0
else if (inittype.eq.6) then
  write(*,'(''Spin Up'')')
  CALL random_number(x0)
  x0=x0*0.1d0
  do istep=2,floor(spinup/dt)
    !write(*,*) istep,floor(inittype/dt)
    if (mod(istep,floor(spinup/dt/10)).eq.0) then; call progress(floor(dble(istep)/floor(spinup/dt/10)));end if;
    call runge_kutta_4th(xnew,x0,k1,k2,k3,k4,F,hx,hy,eps,c,b,dt,dimX,dimY,dimF)
    x0=xnew
  end do
  initialentry=1
  lyapunov=0.0d0
else
  write(*,*) 'inittype has invalid value' ;stop;
end if

end

subroutine write_out(x,tanglin,indexn,fileID,dimX,dimY,dimF)
implicit none
integer :: dimX,dimY,dimF,indexn,fileID
real(kind=8),dimension(dimF) :: x
real(kind=8),dimension(dimF,dimF) :: tanglin

write(1+fileID,rec=indexn) x
!write(2,rec=indexn) tanglin
end

subroutine write_out_notl(x,indexn,fileID,dimX,dimY,dimF)
implicit none
integer :: dimX,dimY,dimF,indexn,fileID
real(kind=8),dimension(dimF) :: x

write(1+fileID,rec=indexn) x

end

subroutine tendency(tend,x,F,hx,hy,eps,c,b,dimX,dimY,dimF)
implicit none
integer :: dimX,dimY,dimF,offset
integer :: i,j
real(kind=8),dimension(dimF) :: x,tend
real(kind=8) :: F,hx,hy,eps,c,b,factor

if (dimY>0) then
factor=hx*c/b/dble(dimY)
else
factor=0
endif
! For the x at the (connected) boundary of the chain
! i==1
offset=dimX
tend(1)=-x(dimX-1)*x(dimX)+x(dimX)*x(2)-x(1)+F-factor*sum(x(offset+1:offset+dimY))

! i==2
offset=dimY+dimX
!write(*,*) x(1),x(3),x(2),sum(x(offset+1:offset+dimY))
tend(2)=-x(dimX)*x(1)+x(1)*x(3)-x(2)+F-factor*sum(x(offset+1:offset+dimY))

! i==dimX
offset=(dimX-1)*dimY+dimX
tend(dimX)=-x(dimX-2)*x(dimX-1)+x(dimX-1)*x(1)-x(dimX)+F-factor*sum(x(offset+1:offset+dimY))

!$OMP PARALLEL DO Private(i) DEFAULT(shared)
do i=3,dimX-1
 offset=(i-1)*dimY+dimX
 tend(i)=-x(i-2)*x(i-1)+x(i-1)*x(i+1)-x(i)+F-factor*sum(x(offset+1:offset+dimY))
end do
!$OMP END PARALLEL DO

if (dimY>0) then
    offset=dimX
    tend(offset+1)=1.0d0/eps*(c*b*(-x(offset+2)*x(offset+3)+x(offset+dimY*dimX)*x(offset+2))-c*x(offset+1)+hy*c/b*x(1))

    ! i==dimY*dimX-1
    tend(offset+dimY*dimX-1)=1.0d0/eps*(c*b*(-x(offset+dimY*dimX)*x(offset+1)+x(offset+dimY*dimX-2)*x(offset+dimY*dimX))-c*x(offset+dimY*dimX-1)+hy*c/b*x(int(ceiling(real(dimX*dimY-1)/real(dimY)))))
    ! i==dimY*dimX
    tend(offset+dimY*dimX)=1.0d0/eps*(c*b*(-x(offset+1)*x(offset+2)+x(offset+dimY*dimX-1)*x(offset+1))-c*x(offset+dimY*dimX)+hy*c/b*x(dimX))
  !$OMP PARALLEL DO Private(j) DEFAULT(shared)
  do j=2,dimX*dimY-2
      tend(dimX+j)=1.0d0/eps*(c*b*(-x(dimX+j+1)*x(dimX+j+2)+x(dimX+j-1)*x(dimX+j+1))-c*x(dimX+j)+hy*c/b*x(int(ceiling(real(j)/real(dimY)))))
  end do
  !$OMP END PARALLEL DO

end if
end

subroutine runge_kutta_4th(xnew,xold,k1,k2,k3,k4,F,hx,hy,eps,c,b,dt,dimX,dimY,dimF)
implicit none
! Perform Runge Kutta 4th Order Steps
integer :: dimX,dimY,dimF
real(kind=8) :: dt,F,hx,hy,eps,c,b
real(kind=8),dimension(dimF) :: xold,xnew,k1,k2,k3,k4

call tendency(k1,xold,F,hx,hy,eps,c,b,dimX,dimY,dimF)
xnew=xold+dt/2.0d0*k1
call tendency(k2,xnew,F,hx,hy,eps,c,b,dimX,dimY,dimF)
xnew=xold+dt/2.0d0*k2
call tendency(k3,xnew,F,hx,hy,eps,c,b,dimX,dimY,dimF)
xnew=xold+dt*k3
call tendency(k4,xnew,F,hx,hy,eps,c,b,dimX,dimY,dimF)
xnew=xold+dt/6.0d0*(k1+2.0d0*k2+2.0d0*k3+k4)
end

subroutine runge_kutta_2nd(xnew,xold,k1,k2,F,hx,hy,eps,c,b,dt,dimX,dimY,dimF)
implicit none
! Perform Runge Kutta 4th Order Steps
integer :: dimX,dimY,dimF
real(kind=8) :: dt,F,hx,hy,eps,c,b
real(kind=8),dimension(dimF) :: xold,xnew,k1,k2,k3,k4

call tendency(k1,xold,F,hx,hy,eps,c,b,dimX,dimY,dimF)
xnew=xold+dt/2.0d0*k1
call tendency(k2,xnew,F,hx,hy,eps,c,b,dimX,dimY,dimF)
xnew=xold+dt/2.0d0*k2
call tendency(k3,xnew,F,hx,hy,eps,c,b,dimX,dimY,dimF)
xnew=xold+dt*k3
call tendency(k4,xnew,F,hx,hy,eps,c,b,dimX,dimY,dimF)
xnew=xold+dt/6.0d0*(k1+2.0d0*k2+2.0d0*k3+k4)
end

subroutine tangent_linear(tangx,x,F,hx,hy,eps,c,b,dimX,dimY,dimF)
implicit none
integer :: dimX,dimY,dimF
integer :: i,j,offset
real(kind=8) :: F,hx,hy,eps,c,b,factor
real(kind=8),dimension(dimF) :: x
real(kind=8),dimension(dimF,dimF) :: tangx
if (dimY>0) then
factor=hx*c/b/dble(dimY)
else
factor=0.0d0
endif

tangx(:,:)=0.0d0

! For the x at the (connected) boundary of the chain
i=1
offset=dimX+(i-1)*dimY
tangx(1,1)=-1
tangx(1,dimX)=-x(dimX-1)+x(2)
tangx(1,dimX-1)=-x(dimX)
tangx(1,2)=x(dimX)
tangx(1,offset+1:offset+dimY)=-factor

i=2
offset=dimX+(i-1)*dimY
tangx(2,2)=-1
tangx(2,1)=-x(dimX)+x(3)
tangx(2,dimX)=-x(1)
tangx(2,3)=x(1)
tangx(2,offset+1:offset+dimY)=-factor

i=dimX
offset=dimX+(i-1)*dimY
tangx(dimX,dimX)=-1
tangx(dimX,dimX-1)=-x(dimX-2)+x(1)
tangx(dimX,dimX-2)=-x(dimX-1)
tangx(dimX,1)=x(dimX-1)
tangx(dimX,offset+1:offset+dimY)=-factor

!$OMP PARALLEL DO SHARED(tangx,c,hx,hy,eps,b,x,dimX) PRIVATE(i,offset)
do i=3,dimX-1
 offset=dimX+(i-1)*dimY
 tangx(i,i)=-1
 tangx(i,i-1)=-x(i-2)+x(i+1)
 tangx(i,i-2)=-x(i-1)
 tangx(i,i+1)=x(i-1)
 tangx(i,offset+1:offset+dimY)=-factor
end do
!$OMP END PARALLEL DO

if (dimY>0) then
  offset=dimX
  j=1
  tangx(offset+j,offset+j)=-c/eps
  tangx(offset+j,offset+j+1)=-c*b*(x(offset+j+2)-x(offset+dimY*dimX))/eps
  tangx(offset+j,offset+j+2)=-c*b*x(offset+j+1)/eps
  tangx(offset+j,offset+dimY*dimX)=c*b*x(offset+j+1)/eps
  tangx(offset+j,int(ceiling(real(j)/real(dimY))))=c*hy/b/eps

  j=dimY*dimX-1
  tangx(offset+j,offset+j)=-c/eps
  tangx(offset+j,offset+dimY*dimX)=-c*b*(x(offset+1)-x(offset+dimY*dimX-2))/eps
  tangx(offset+j,offset+1)=-c*b*x(offset+dimY*dimX)/eps
  tangx(offset+j,offset+dimY*dimX-2)=c*b*x(offset+dimY*dimX)/eps
  tangx(offset+j,int(ceiling(real(j)/real(dimY))))=c*hy/b/eps

  j=dimY*dimX
  tangx(offset+j,offset+j)=-c/eps
  tangx(offset+j,offset+1)=-c*b*(x(offset+2)-x(offset+dimY*dimX-1))/eps
  tangx(offset+j,offset+2)=-c*b*x(offset+1)/eps
  tangx(offset+j,offset+dimY*dimX-1)=c*b*x(offset+1)/eps
  tangx(offset+j,int(ceiling(real(j)/real(dimY))))=c*hy/b/eps

!$OMP PARALLEL DO SHARED(tangx,c,hx,hy,eps,b,x,dimY,dimX) PRIVATE(j,offset)
do j=2,dimX*dimY-2
      offset=dimX
      tangx(offset+j,offset+j)=-c/eps
      tangx(offset+j,offset+j+1)=-c*b*(x(offset+j+2)-x(offset+j-1))/eps
      tangx(offset+j,offset+j+2)=-c*b*x(offset+j+1)/eps
      tangx(offset+j,offset+j-1)=c*b*x(offset+j+1)/eps
      tangx(offset+j,int(ceiling(real(j)/real(dimY))))=c*hy/b/eps
end do
!$OMP END PARALLEL DO
end if
end

subroutine rungekutta4thtl(tanglin,xold,k1,k2,k3,k4,F,hx,hy,eps,c,b,dt,dimX,dimY,dimF)
implicit none
! Perform Runge Kutta 4th Order Steps
integer :: dimX,dimY,dimF
real(kind=8) :: dt,dt2,dt6,F,hx,hy,eps,c,b
real(kind=8),dimension(dimF) :: xold,xdummy,k1,k2,k3,k4
real(kind=8),dimension(dimF,dimF) :: t1,t2,t3,t4,t1h,t2h,t3h,t4h,one,tanglin

dt2=dt/2.0d0
dt6=dt/6.0d0

call tangent_linear(t1,xold,F,hx,hy,eps,c,b,dimX,dimY,dimF)
xdummy=xold+dt/2.0d0*k1
call tangent_linear(t2,xdummy,F,hx,hy,eps,c,b,dimX,dimY,dimF)
xdummy=xold+dt/2.0d0*k2
call tangent_linear(t3,xdummy,F,hx,hy,eps,c,b,dimX,dimY,dimF)
xdummy=xold+dt*k3
call tangent_linear(t4,xdummy,F,hx,hy,eps,c,b,dimX,dimY,dimF)

t1h(:,:)=t1(:,:)
t2h(:,:)=t2(:,:)
t3h(:,:)=t3(:,:)
t4h(:,:)=t4(:,:)
call dgemm ('n', 'n', dimF, dimF, dimF, dt2, t2, dimF,t1h, dimF,1.0d0, t2h, dimF)
call dgemm ('n', 'n', dimF, dimF, dimF, dt2, t3, dimF,t2h, dimF,1.0d0, t3h, dimF)
call dgemm ('n', 'n', dimF, dimF, dimF, dt , t4, dimF,t3h, dimF,1.0d0, t4h, dimF)
!t2h=matmul(t2,t1h)*dt2+t2h
!t2h=matmul(t3,t2h)*dt2+t3h
!t2h=matmul(t4,t3h)*dt2+t4h

call dlaset('',dimF,dimF, 0.0d0, 1.0d0, one, dimF)
tanglin(:,:)=one(:,:) + dt6*(t1h(:,:)+2.0d0*t2h(:,:)+2.0d0*t3h(:,:)+t4h(:,:))

end

subroutine qr(tanglin,blv,tau,lyapunov,diag,samplerate,dt,indexI,fileID,dimF,lwork,saveswitch)
implicit none
integer,intent(in) :: dimF,samplerate,indexI,saveswitch
integer :: lwork,info,k,fileID
real(kind=8),intent(in) :: dt
real(kind=8),dimension(dimF,dimF),intent(inout) :: tanglin,blv
real(kind=8),dimension(lwork) :: work
real(kind=8),dimension(dimF) :: lyapunov,diag,tau,work2
!write(*,*) 'test',blv(1,1),tanglin(1,1)
diag=0.0d0
! multiply the Propagator from the right side with the non transposed q matrix from the qr decomposition
call dorm2r("r","n",dimF,dimF,dimF,blv,dimF,tau,tanglin,dimF,work2,info)
! from here on tanglin contains the new information tanglin*blv_old
call dgeqrf(dimF,dimF,tanglin,dimF,tau,work,lwork, info) ! qr decomposition

do k=1,dimF
!   write(*,*) k,tanglin(k,k)
  diag(k)=log(abs(tanglin(k,k)))/(dble(samplerate)*dt)
end do
if (saveswitch.eq.1) then
  write(3+fileID,rec=indexI) diag
  write(4+fileID,rec=indexI) tanglin,tau
endif

blv(:,:)=tanglin(:,:)
lyapunov=lyapunov+diag
end

function ky(lyap,dimF)
integer :: dimF,i
real(kind=8) :: ky
real(kind=8),dimension(dimF) :: lyap
ky=0.0d0
i=0
do while (ky.ge.0 .and. i<dimF)
  i=i+1
  ky=ky+lyap(i)
end do
ky=i-1+(ky-lyap(i))/(lyap(i))
return
end function

!
!Taken from https://software.intel.com/en-us/forums/intel-fortran-compiler-for-linux-and-mac-os-x/topic/270155
!

subroutine progress(j)
  implicit none
  integer(kind=4)::j,k
  character(len=19)::bar
  bar="???% |          |"
  write(unit=bar(1:3),fmt="(i3)") 10*j
  do k=1,j
    bar(6+k:6+k)="*"
  enddo
  ! print the progress bar.
  write(*,fmt="(a1,a1,a17)") '+',char(13), bar

  return
end subroutine progress

subroutine progress100(j)
  implicit none
  integer(kind=4)::j,k
  character(len=109)::bar
  bar="???% |                                                                                |"
  write(unit=bar(1:3),fmt="(i3)") j
  do k=1,j
    bar(6+k:6+k)="*"
  enddo
  ! print the progress bar.
  write(*,fmt="(a1,a1,a107)") '+',char(13), bar

  return
end subroutine progress100

subroutine init_random_seed()
  use iso_fortran_env, only: int64
  implicit none
  integer, allocatable :: seed(:)
  integer :: i, n, un, istat, dt(8), pid
  integer(int64) :: t
  integer:: getpid

  call random_seed(size = n)
  allocate(seed(n))
  ! First try if the OS provides a random number generator
  open(newunit=un, file="/dev/urandom", access="stream", &
	form="unformatted", action="read", status="old", iostat=istat)
  if (istat == 0) then
      read(un) seed
      close(un)
  else
      ! Fallback to XOR:ing the current time and pid. The PID is
      ! useful in case one launches multiple instances of the same
      ! program in parallel.
      call system_clock(t)
      if (t == 0) then
	call date_and_time(values=dt)
	t = (dt(1) - 1970) * 365_int64 * 24 * 60 * 60 * 1000 &
	      + dt(2) * 31_int64 * 24 * 60 * 60 * 1000 &
	      + dt(3) * 24_int64 * 60 * 60 * 1000 &
	      + dt(5) * 60 * 60 * 1000 &
	      + dt(6) * 60 * 1000 + dt(7) * 1000 &
	      + dt(8)
      end if
      pid = getpid()
      t = ieor(t, int(pid, kind(t)))
      do i = 1, n
	seed(i) = lcg(t)
      end do
  end if
  call random_seed(put=seed)
contains
  ! This simple PRNG might not be good enough for real work, but is
  ! sufficient for seeding a better PRNG.
  function lcg(s)
    integer :: lcg
    integer(int64) :: s
    if (s == 0) then
	s = 104729
    else
	s = mod(s, 4294967296_int64)
    end if
    s = mod(s * 279470273_int64, 4294967291_int64)
    lcg = int(mod(s, int(huge(0), int64)), kind(0))
  end function lcg
end subroutine init_random_seed

subroutine write_model_parameters(dimX,dimY,intscheme,inittype,spinup,tl,gin,dt,samplerate,timeint,F,hx,hy,eps,c,b,fileID)
implicit none
integer :: dimX,dimY,intscheme,inittype,tl,gin,samplerate,fileID
real(kind=8) :: dt,timeint,F,hx,hy,eps,c,b,spinup
!write(*,'(''Model parameters'')')
write(*,'(''----------------'')')
write(*,'(''Dimension of X : '',i20)') dimX
write(*,'(''Dimension of Y : '',i20)') dimY
write(*,'(''             F : '',F20.2)') F
write(*,'(''       epsilon : '',F20.2)') eps
write(*,'(''            hx : '',F20.2)') hx
write(*,'(''            hy : '',F20.2)') hy
write(*,'(''             c : '',F20.2)') c
write(*,'(''             b : '',F20.2)') b
write(*,'(''   Sample Rate : '',i20)') samplerate
write(*,'(''   Time Step   : '',F20.5)') dt
write(*,'(''         Length: '',F20.2)') timeint

if (inittype.eq.1) then
  write(*,'(''     Init Type : Random Initial Condition'')')
elseif (inittype.eq.2) then
  write(*,'(''     Init Type : Stationary + Perturb'')')
elseif (inittype.eq.3) then
  write(*,'(''     Init Type : Fixpoint Solution'')')
elseif (inittype.eq.4) then
  write(*,'(''     Init Type : Restart'')')
elseif (inittype.eq.5) then
  write(*,'(''     Init Type : Intialize with initialstate.dat'')')
elseif (inittype.eq.6) then
  write(*,'(''     Init Type : Intialize with spinup of '',F20.2,'' MTU'')') spinup
endif

if (tl.eq.1) then
  write(*,'(''      QR steps : Yes'')')
else
  write(*,'(''      QR steps : No'')')
endif
if (gin.eq.1) then
  write(*,'(''      CLV Comp : Yes'')')
else
  write(*,'(''      CLV Comp : No'')')
endif

write(9+fileID,'(''----------------'')')
write(9+fileID,'(''Dimension of X : '',i20)') dimX
write(9+fileID,'(''Dimension of Y : '',i20)') dimY
write(9+fileID,'(''             F : '',F20.2)') F
write(9+fileID,'(''       epsilon : '',F20.2)') eps
write(9+fileID,'(''            hx : '',F20.2)') hx
write(9+fileID,'(''            hy : '',F20.2)') hy
write(9+fileID,'(''             c : '',F20.2)') c
write(9+fileID,'(''             b : '',F20.2)') b
write(9+fileID,'(''   Sample Rate : '',i20)') samplerate
write(9+fileID,'(''   Time Step   : '',F20.5)') dt
write(9+fileID,'(''         Length: '',F20.2)') timeint

if (inittype.eq.1) then
  write(9+fileID,'(''     Init Type : Random Initial Condition'')')
elseif (inittype.eq.2) then
  write(9+fileID,'(''     Init Type : Stationary + Perturb'')')
elseif (inittype.eq.3) then
  write(9+fileID,'(''     Init Type : Fixpoint Solution'')')
elseif (inittype.eq.4) then
  write(9+fileID,'(''     Init Type : Restart'')')
elseif (inittype.eq.5) then
  write(9+fileID,'(''     Init Type : Intialize with initialstate.dat'')')
elseif (inittype.eq.6) then
  write(9+fileID,'(''     Init Type : Intialize with spinup of '',F20.2,'' MTU'')') spinup
endif

if (tl.eq.1) then
  write(9+fileID,'(''      QR steps : Yes'')')
else
  write(9+fileID,'(''      QR steps : No'')')
endif
if (gin.eq.1) then
  write(9+fileID,'(''      CLV Comp : Yes'')')
else
  write(9+fileID,'(''      CLV Comp : No'')')
endif

end subroutine write_model_parameters

character(len=20) function str(k)
!   "Convert an integer to string."
    integer, intent(in) :: k
    write (str, *) k
    str = adjustl(str)
end function str


program stack

   implicit none

   integer, parameter :: n = 14490
   integer :: i, j, k
   real :: a(n, n)

   do k = 1, 1
      do i = 1, n
         do j = 1, n
            a(j, i) = j + 1.0/real(n)*i
         end do
      end do
   end do

end program


      SUBROUTINE dlocate(xx,x,indx)
      IMPLICIT NONE
      DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: xx
      DOUBLE PRECISION, INTENT(IN) :: x
      INTEGER, INTENT(OUT) :: indx
      INTEGER :: n,jl,jm,ju
      LOGICAL :: ascnd
!      write(6,*) 'xx: ',xx,x,size(xx)
      n=size(xx)
      ascnd = (xx(n) >= xx(1))
      jl=0
      ju=n+1
      do
        if (ju-jl <= 1) exit
        jm=(ju+jl)/2
        if (ascnd .eqv. (x >= xx(jm))) then
          jl=jm
        else
          ju=jm
        end if
      end do
      if (x == xx(1)) then
        indx=1
      else if (x == xx(n)) then
        indx=n-1
      else
        indx=jl
      end if
      END SUBROUTINE dlocate

      SUBROUTINE locate(xx,x,indx)
      IMPLICIT NONE
      REAL, DIMENSION(:), INTENT(IN) :: xx
      REAL, INTENT(IN) :: x
      INTEGER, INTENT(OUT) :: indx
      INTEGER :: n,jl,jm,ju
      LOGICAL :: ascnd
!      write(6,*) 'xx: ',xx,x,size(xx)
      n=size(xx)
      ascnd = (xx(n) >= xx(1))
      jl=0
      ju=n+1
      do
        if (ju-jl <= 1) exit
        jm=(ju+jl)/2
        if (ascnd .eqv. (x >= xx(jm))) then
          jl=jm
        else
          ju=jm
        end if
      end do
      if (x == xx(1)) then
        indx=1
      else if (x == xx(n)) then
        indx=n-1
      else
        indx=jl
      end if
      END SUBROUTINE locate


/* Examples for testing */

 "hello";

unit;

{x=true, y=false};
{x=true, y=false}.x;
{true, false};
{true, false}.1;

if true then {x=true,y=false,a=false} else {y=false,x={},b=false};

timesfloat 2.0 3.14159;

let x=true in x;

lambda x:Top. x;
 (lambda x:Top. x) (lambda x:Top. x);
(lambda x:Top->Top. x) (lambda x:Top. x);

(lambda r:{x:Top->Top}. r.x r.x)
  {x=lambda z:Top.z, y=lambda z:Top.z};

lambda x:Bool. x;
(lambda x:Bool->Bool. if x false then true else false)
  (lambda x:Bool. if x then false else true);

lambda x:Nat. succ x;
(lambda x:Nat. succ (succ x)) (succ 0);

T = Nat->Nat;
lambda f:T. lambda x:Nat. f (f x);

lambda x:A. x;


! ###############################################################################################################################
! Begin MIT license text.
! _______________________________________________________________________________________________________

! Copyright 2019 Dr William R Case, Jr (dbcase29@gmail.com)

! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
! associated documentation files (the "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to
! the following conditions:

! The above copyright notice and this permission notice shall be included in all copies or substantial
! portions of the Software and documentation.

! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
! _______________________________________________________________________________________________________

! End MIT license text.

   MODULE SYM_MAT_DECOMP_LAPACK_Interface

   INTERFACE

      SUBROUTINE SYM_MAT_DECOMP_LAPACK ( CALLING_SUBR, MATIN_NAME, MATIN_SET, NROWS, NTERMS, I_MATIN, J_MATIN, MATIN, PRT_ERRS,    &

                                         MATIN_DIAG_RAT, EQUIL_MATIN, CALC_COND_NUM, DEB_PRT, EQUED, MATIN_SDIA, K_INORM, RCOND,   &
                                         EQUIL_SCALE_FACS, INFO )

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE
      USE IOUNT1, ONLY                :  WRT_LOG, ERR, F04, F06
      USE SCONTR, ONLY                :  BLNK_SUB_NAM, FACTORED_MATRIX, FATAL_ERR, LINKNO
      USE TIMDAT, ONLY                :  HOUR, MINUTE, SEC, SFRAC, STIME, TSEC
      USE CONSTANTS_1, ONLY           :  ZERO, ONE, ONEPP6
      USE PARAMS, ONLY                :  BAILOUT, EPSIL, MAXRATIO, SUPINFO
      USE LAPACK_DPB_MATRICES, ONLY   :  ABAND, LAPACK_S
      USE DEBUG_PARAMETERS, ONLY      :  DEBUG, NDEBUG
      USE MACHINE_PARAMS, ONLY        :  MACH_LARGE_NUM
      USE LAPACK_LIN_EQN_DPB
      USE SUBR_BEGEND_LEVELS, ONLY    :  SYM_MAT_DECOMP_LAPACK_BEGEND

      IMPLICIT NONE

      CHARACTER, PARAMETER            :: CR13 = CHAR(13)   ! This causes a carriage return simulating the "+" action in a FORMAT

      CHARACTER(LEN=*) , INTENT(IN)   :: CALC_COND_NUM     ! If "Y" calc RCOND (reciprocal of condition number of MATIN)
      CHARACTER(LEN=*) , INTENT(IN)   :: CALLING_SUBR      ! The subr that called this subr (used for output error purposes)
      CHARACTER(LEN=*) , INTENT(IN)   :: EQUIL_MATIN       ! If "Y" attempt to equilibrate MATIN (if it needs it)
      CHARACTER(1*BYTE), INTENT(OUT)  :: EQUED             ! 'Y' if MATIN was equilibrated in subr EQUILIBRATE (called herein)
      CHARACTER(LEN=*) , INTENT(IN)   :: MATIN_DIAG_RAT    ! If "Y" calculate max ratio of matrix diagonal to factor diagonal
      CHARACTER(LEN=*) , INTENT(IN)   :: MATIN_NAME        ! Name of matrix to be decomposed
      CHARACTER(LEN=*) , INTENT(IN)   :: MATIN_SET         ! Set designator for the input matrix. If it corresponds to a MYSTRAN
      CHARACTER(LEN=*) , INTENT(IN)   :: PRT_ERRS          ! If not 'N', print singularity errors

      CHARACTER( 1*BYTE), PARAMETER   :: INORM    = 'I'    ! Indicates to calculate the infinity norm via LAPACK function DLANSB
      CHARACTER( 1*BYTE), PARAMETER   :: UPLO     = 'U'    ! Indicates upper triang part of matrix is stored

      INTEGER(LONG), INTENT(IN)       :: DEB_PRT(2)        ! Debug numbers to say whether to write ABAND and/or its decomp to file
      INTEGER(LONG), INTENT(IN)       :: NROWS             ! Number of rows in sparse matrix MATIN
      INTEGER(LONG), INTENT(IN)       :: NTERMS            ! Number of nonzeros in sparse matrix MATIN
      INTEGER(LONG), INTENT(IN)       :: I_MATIN(NROWS+1)  ! Indicators of number of nonzero terms in rows of matrix MATIN
      INTEGER(LONG), INTENT(IN)       :: J_MATIN(NTERMS)   ! Col numberts of nonzero terms in matrix MATIN

      INTEGER(LONG), INTENT(INOUT)    :: INFO              ! Output from LAPACK routine to do factorization of ABAND

      INTEGER(LONG), INTENT(OUT)      :: MATIN_SDIA        ! No. of superdiags in the MATIN upper triangle
      INTEGER(LONG), PARAMETER        :: SUBR_BEGEND = SYM_MAT_DECOMP_LAPACK_BEGEND

      REAL(DOUBLE) , INTENT(IN)       :: MATIN(NTERMS)     ! A small number to compare real zero
      REAL(DOUBLE) , INTENT(OUT)      :: RCOND             ! Recrip of cond no. of MATIN. Determined in  subr COND_NUM
      REAL(DOUBLE) , INTENT(OUT)      :: K_INORM           ! Inf norm of MATIN matrix (det in  subr COND_NUM)

      REAL(DOUBLE) , INTENT(OUT)      :: EQUIL_SCALE_FACS(NROWS)

      END SUBROUTINE SYM_MAT_DECOMP_LAPACK

   END INTERFACE

   END MODULE SYM_MAT_DECOMP_LAPACK_Interface


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   non :    A non-autonomous boundary value problem
!----------------------------------------------------------------------
!----------------------------------------------------------------------

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

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

      DOUBLE PRECISION U1,U2,X,P

       U1=U(1)
       U2=U(2)
       X =U(3)
       P=PAR(1)

       F(1)=U2
       F(2)=-P*EXP(X**3*U1)
       F(3)=1.d0

      END SUBROUTINE FUNC

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

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

       PAR(1)=0.d0
       U(1)=0.d0
       U(2)=0.d0
       U(3)=X

      END SUBROUTINE STPNT

      SUBROUTINE BCND(NDIM,PAR,ICP,NBC,U0,U1,FB,IJAC,DBC)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), NBC, IJAC
      DOUBLE PRECISION, INTENT(IN) :: PAR(*), U0(NDIM), U1(NDIM)
      DOUBLE PRECISION, INTENT(OUT) :: FB(NBC)
      DOUBLE PRECISION, INTENT(INOUT) :: DBC(NBC,*)

       FB(1)=U0(1)
       FB(2)=U1(1)
       FB(3)=U0(3)

      END SUBROUTINE BCND

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT

      SUBROUTINE PVLS
      END SUBROUTINE PVLS


!==========================================================================
elemental subroutine gsw_rho_first_derivatives (sa, ct, p, drho_dsa, &
                                                drho_dct, drho_dp)
!==========================================================================
!
!  Calculates the three (3) partial derivatives of in-situ density with
!  respect to Absolute Salinity, Conservative Temperature and pressure.
!  Note that the pressure derivative is done with respect to pressure in
!  Pa, not dbar. This function uses the computationally-efficient expression
!  for specific volume in terms of SA, CT and p (Roquet et al., 2014).
!
!  SA  =  Absolute Salinity                                        [ g/kg ]
!  CT  =  Conservative Temperature (ITS-90)                       [ deg C ]
!  p   =  sea pressure                                             [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar )
!
!  drho_dSA  =  partial derivatives of density             [ kg^2/(g m^3) ]
!                 with respect to Absolute Salinity
!  drho_dCT  =  partial derivatives of density               [ kg/(K m^3) ]
!                 with respect to Conservative Temperature
!  drho_dP   =  partial derivatives of density              [ kg/(Pa m^3) ]
!                 with respect to pressure in Pa
!--------------------------------------------------------------------------

use gsw_mod_teos10_constants, only : pa2db, gsw_sfac, offset

use gsw_mod_specvol_coefficients

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, ct, p
real (r8), intent(out), optional :: drho_dsa, drho_dct, drho_dp

real (r8) :: rho2, v_ct, v_p, v_sa, xs, ys, z, v

xs = sqrt(gsw_sfac*sa + offset)
ys = ct*0.025_r8
z = p*1e-4_r8

v = v000 + xs*(v010 + xs*(v020 + xs*(v030 + xs*(v040 + xs*(v050 &
    + v060*xs))))) + ys*(v100 + xs*(v110 + xs*(v120 + xs*(v130 + xs*(v140 &
    + v150*xs)))) + ys*(v200 + xs*(v210 + xs*(v220 + xs*(v230 + v240*xs))) &
    + ys*(v300 + xs*(v310 + xs*(v320 + v330*xs)) + ys*(v400 + xs*(v410 &
    + v420*xs) + ys*(v500 + v510*xs + v600*ys))))) + z*(v001 + xs*(v011 &
    + xs*(v021 + xs*(v031 + xs*(v041 + v051*xs)))) + ys*(v101 + xs*(v111 &
    + xs*(v121 + xs*(v131 + v141*xs))) + ys*(v201 + xs*(v211 + xs*(v221 &
    + v231*xs)) + ys*(v301 + xs*(v311 + v321*xs) + ys*(v401 + v411*xs &
    + v501*ys)))) + z*(v002 + xs*(v012 + xs*(v022 + xs*(v032 + v042*xs))) &
    + ys*(v102 + xs*(v112 + xs*(v122 + v132*xs)) + ys*(v202 + xs*(v212 &
    + v222*xs) + ys*(v302 + v312*xs + v402*ys))) + z*(v003 + xs*(v013 &
    + v023*xs) + ys*(v103 + v113*xs + v203*ys) + z*(v004 + v014*xs + v104*ys &
    + z*(v005 + v006*z)))))

rho2 = (1.0_r8/v)**2

if (present(drho_dsa)) then

    v_sa = b000 + xs*(b100 + xs*(b200 + xs*(b300 + xs*(b400 + b500*xs)))) &
           + ys*(b010 + xs*(b110 + xs*(b210 + xs*(b310 + b410*xs))) &
           + ys*(b020 + xs*(b120 + xs*(b220 + b320*xs)) + ys*(b030 &
           + xs*(b130 + b230*xs) + ys*(b040 + b140*xs + b050*ys)))) &
           + z*(b001 + xs*(b101 + xs*(b201 + xs*(b301 + b401*xs))) &
           + ys*(b011 + xs*(b111 + xs*(b211 + b311*xs)) + ys*(b021 &
           + xs*(b121 + b221*xs) + ys*(b031 + b131*xs + b041*ys))) &
           + z*(b002 + xs*(b102 + xs*(b202 + b302*xs))+ ys*(b012 &
           + xs*(b112 + b212*xs) + ys*(b022 + b122*xs + b032*ys)) &
           + z*(b003 +  b103*xs + b013*ys + b004*z)))

    drho_dsa = -rho2*0.5_r8*gsw_sfac*v_sa/xs

end if

if (present(drho_dct)) then

    v_ct = a000 + xs*(a100 + xs*(a200 + xs*(a300 + xs*(a400 + a500*xs)))) &
           + ys*(a010 + xs*(a110 + xs*(a210 + xs*(a310 + a410*xs))) &
           + ys*(a020 + xs*(a120 + xs*(a220 + a320*xs)) + ys*(a030 &
           + xs*(a130 + a230*xs) + ys*(a040 + a140*xs + a050*ys )))) &
           + z*(a001 + xs*(a101 + xs*(a201 + xs*(a301 + a401*xs))) &
           + ys*(a011 + xs*(a111 + xs*(a211 + a311*xs)) + ys*(a021 &
           + xs*(a121 + a221*xs) + ys*(a031 + a131*xs + a041*ys))) &
           + z*(a002 + xs*(a102 + xs*(a202 + a302*xs)) + ys*(a012 &
           + xs*(a112 + a212*xs) + ys*(a022 + a122*xs + a032*ys)) &
           + z*(a003 + a103*xs + a013*ys + a004*z)))

    drho_dct = -rho2*0.025_r8*v_ct

end if

if (present(drho_dp)) then

    v_p = c000 + xs*(c100 + xs*(c200 + xs*(c300 + xs*(c400 + c500*xs)))) &
          + ys*(c010 + xs*(c110 + xs*(c210 + xs*(c310 + c410*xs))) + ys*(c020 &
          + xs*(c120 + xs*(c220 + c320*xs)) + ys*(c030 + xs*(c130 + c230*xs) &
          + ys*(c040 + c140*xs + c050*ys)))) + z*(c001 + xs*(c101 + xs*(c201 &
          + xs*(c301 + c401*xs))) + ys*(c011 + xs*(c111 + xs*(c211 + c311*xs)) &
          + ys*(c021 + xs*(c121 + c221*xs) + ys*(c031 + c131*xs + c041*ys))) &
          + z*(c002 + xs*(c102 + c202*xs) + ys*(c012 + c112*xs + c022*ys) &
          + z*(c003 + c103*xs + c013*ys + z*(c004 + c005*z))))

    drho_dp = -rho2*1e-4_r8*pa2db*v_p

end if

return
end subroutine

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


!==========================================================================
elemental subroutine gsw_ice_fraction_to_freeze_seawater (sa, ct, p, &
                                          t_ih, sa_freeze, ct_freeze, w_ih)
!==========================================================================
!
!  Calculates the mass fraction of ice (mass of ice divided by mass of ice
!  plus seawater), which, when melted into seawater having (SA,CT,p) causes
!  the final dilute seawater to be at the freezing temperature.  The other
!  outputs are the Absolute Salinity and Conservative Temperature of the
!  final diluted seawater.
!
!  SA   =  Absolute Salinity of seawater                           [ g/kg ]
!  CT   =  Conservative Temperature of seawater (ITS-90)          [ deg C ]
!  p    =  sea pressure                                            [ dbar ]
!            ( i.e. absolute pressure - 10.1325d0 dbar )
!  t_Ih =  in-situ temperature of the ice at pressure p (ITS-90)  [ deg C ]
!
!  SA_freeze = Absolute Salinity of seawater after the mass fraction of
!              ice, ice_fraction, at temperature t_Ih has melted into the
!              original seawater, and the final mixture is at the freezing
!              temperature of seawater.                            [ g/kg ]
!
!  CT_freeze = Conservative Temperature of seawater after the mass
!              fraction, w_Ih, of ice at temperature t_Ih has melted into
!              the original seawater, and the final mixture is at the
!              freezing temperature of seawater.                  [ deg C ]
!
!  w_Ih      = mass fraction of ice, having in-situ temperature t_Ih,
!              which, when melted into seawater at (SA,CT,p) leads to the
!              final diluted seawater being at the freezing temperature.
!              This output must be between 0 and 1.              [unitless]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_enthalpy_ice, gsw_t_freezing_exact
use gsw_mod_toolbox, only : gsw_enthalpy_first_derivatives_ct_exact
use gsw_mod_toolbox, only : gsw_ct_freezing_exact, gsw_enthalpy_ct_exact
use gsw_mod_toolbox, only : gsw_ct_freezing_first_derivatives

use gsw_mod_error_functions, only : gsw_error_code, gsw_error_limit

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, ct, p, t_ih
real (r8), intent(out) :: sa_freeze, ct_freeze, w_ih

integer :: no_iter
real (r8) :: ctf, ctf_mean, ctf_old, ctf_plus1, ctf_zero
real (r8) :: dfunc_dsaf, func, func_plus1, func_zero, h, h_ih
real (r8) :: saf, saf_mean, saf_old, tf, h_hat_sa, h_hat_ct, ctf_sa

real (r8), parameter :: sa0 = 0.0_r8, saturation_fraction = 0.0_r8

character (*), parameter :: func_name = "gsw_ice_fraction_to_freeze_seawater"

ctf = gsw_ct_freezing_exact(sa,p,saturation_fraction)
if (ct .lt. ctf) then
    ! The seawater ct input is below the freezing temp
    sa_freeze = gsw_error_code(1,func_name)
    ct_freeze = sa_freeze
    w_ih = sa_freeze
    return
end if

tf = gsw_t_freezing_exact(sa0,p,saturation_fraction)
if (t_ih .gt. tf) then
    ! The input, t_Ih, exceeds the freezing temperature at sa = 0
    sa_freeze = gsw_error_code(2,func_name)
    ct_freeze = sa_freeze
    w_ih = sa_freeze
    return
end if

h = gsw_enthalpy_ct_exact(sa,ct,p)
h_ih = gsw_enthalpy_ice(t_ih,p)

ctf_zero = gsw_ct_freezing_exact(sa0,p,saturation_fraction)
func_zero = sa*(gsw_enthalpy_ct_exact(sa0,ctf_zero,p) - h_ih)

ctf_plus1 = gsw_ct_freezing_exact(sa+1.0_r8,p,saturation_fraction)
func_plus1 = sa*(gsw_enthalpy_ct_exact(sa+1.0_r8,ctf_plus1,p) - h) - (h - h_ih)

saf = -(sa+1.0_r8)*func_zero/(func_plus1 - func_zero)      ! initial guess
ctf = gsw_ct_freezing_exact(saf,p,saturation_fraction)
call gsw_enthalpy_first_derivatives_ct_exact(saf,ctf,p,h_hat_sa,h_hat_ct)
call gsw_ct_freezing_first_derivatives(saf,p,1.0_r8,ctfreezing_sa=ctf_sa)

dfunc_dsaf = sa*(h_hat_sa + h_hat_ct*ctf_sa) - (h - h_ih)

do no_iter = 1, 2
    saf_old = saf
    ctf_old = ctf
    func = sa*(gsw_enthalpy_ct_exact(saf_old,ctf_old,p) - h) &
           - (saf_old - sa)*(h - h_ih)
    saf = saf_old - func/dfunc_dsaf
    saf_mean = 0.5_r8*(saf + saf_old)
    ctf_mean = gsw_ct_freezing_exact(saf_mean,p,saturation_fraction)
    call gsw_enthalpy_first_derivatives_ct_exact(saf_mean,ctf_mean,p,h_hat_sa, &
                                                 h_hat_ct)
    call gsw_ct_freezing_first_derivatives(saf_mean,p,saturation_fraction, &
                                           ctfreezing_sa=ctf_sa)
    dfunc_dsaf = sa*(h_hat_sa + h_hat_ct*ctf_sa) - (h - h_ih)
    saf = saf_old - func/dfunc_dsaf
    ctf = gsw_ct_freezing_exact(saf,p,saturation_fraction)
end do

! After these 2 iterations of this modified Newton-Raphson method, the
! error in SA_freeze is less than 1.3d0x10^-13 g/kg, in CT_freeze is less than
! 4x10^-13 deg C and in w_Ih is less than 3.8d0x10^-15 which represent machine
! precision for these calculations.

sa_freeze = saf
ct_freeze = ctf
w_ih = (h - gsw_enthalpy_ct_exact(sa_freeze,ct_freeze,p))/(h - h_ih)

return
end subroutine