!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!        FILE WITH PARAMETERS FOR SIMULATION                                 !!!!!!!!
!!!!!!!!        ALL PARAMETERS EXPLAINED BELOW                                      !!!!!!!!
!!!!!!!!        VARIABLES EXPLAINED AT TABLE AT THE END                             !!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	SUBROUTINE config()
	USE PARAMETERS
	IMPLICIT NONE
	REAL*8 :: tmp
!====================== FOLDER NAME - 6 CHARACTERS ========================================!
	folder = "data01"
	output_fold = "output"
!==========================================================================================!
!======================== PRE-SYNAPTIC NEURONS (PATHWAYS)==================================!
	!number of pathways
	n_pw = 16
	!number of excitatory neurons per pathway
	ne_pw = 200
	!number of inhibitory neurons type 1 per pathway
	ni_pw1 = 25
	!number of inhibitory neurons type 2 per pathway
	ni_pw2 = 25
	!total number of pre-synaptic neurons
	ne = n_pw*ne_pw
	ni1 = n_pw*ni_pw1
	ni2 = n_pw*ni_pw2
	tot_n = ne+ni1+ni2
	!preferred input signal number
	pref_pw = 9

!==========================================================================================!
!============================== SIMULATION PARAMETERS =====================================!

	!integration time step (ms)
	dt = 0.1d0
	!pi
	dpi = 2.0d0*(4.0d0*ATAN(1.0d0))
	!one second in iterations
	one_sec = INT(1000.0d0/dt)

!==========================================================================================!
!============================== DATA EXPORT PARAMETERS ====================================!

	tot_mins= 2.0d0 ! total number of minutes for the simulation
	actvity_smpl_rt= 10.0d0 ! 10 ms sampling rate
	steps_smpl= INT(actvity_smpl_rt/dt) ! number of simulation steps per sample

!==========================================================================================!
!==================NEURON PARAMETERS==============================!
	!neuron membrane potential time constant, tau (ms)
	pr(1) = 30.0d0
	!resting membrane potential (mV) -> same as reset
	pr(2) = -65.0d0
	!refractory period excitatory (ms)
	pr(3) = 5.0d0
	!spiking threshold (mV)
	pr(4) = -50.0d0

	!filter time constant for output rate (ms)
	pr(11) = 250.0d0
	pr(12) = DEXP(-1.0d0*dt/pr(11))
	pr(13) = 1000.0d0/pr(11)
!==========================================================================================!
!========================== SYNAPSE PARAMETERS ============================================!
	!reversal potential - excitatory - AMPA (mV) -> not used
	pr(31) = 0.0d0
	!reversal potential - inhibitory - GABA_A (mV)
	pr(32) = -80.0d0
	!synaptic time constant - AMPA (ms)
	pr(35) = 5.0d0
	pr(35) = EXP(-1.0d0*dt/pr(35))
	!synaptic time constant - GABA_A (ms)
	pr(36) = 10.0d0
	pr(36) = EXP(-1.0d0*dt/pr(36))
!==========================================================================================!
!================================ EXTERNAL INPUT ==========================================!
	!background firing-rate -> excitatory neurons (Hz)
	pr(75) = 2.0d0
	pr(75) = (dt*pr(75))/1000.0d0
	!background firing-rate -> inhibitory neurons (Hz)
	pr(76) = 4.0d0
	pr(76) = (dt*pr(76))/1000.0d0

	!tau for OU process (ms)
	pr(80) = 50.0d0
	pr(80) = pr(80)/10.0d0
	!decay 1
	pr(81) = DEXP(-dt/pr(80))
	!decay 2
	pr(82) = 1.0d0 - pr(81)
	!amplitude -> excitatory neurons (Hz)
	pr(83) = 5.0d0
	!amplitude -> inhibitory neurons (Hz)
	pr(84) = 10.0d0

	!filter time constant for input rate (ms)
	pr(86) = 10.0d0 ! presynaptic time constant = 10 ms (tau_Z)
	pr(87) = DEXP(-1.0d0*dt/pr(86))
	pr(88) = 1000.0d0/pr(86)
!==========================================================================================!
!======================== FILES WITH DATA FROM SIMULATION =================================!
	! OPEN(100,file="plots_tmp.txt") ALSO COMMENTED THIS BLOCK OUT!
	! WRITE(100,"(A6)")folder
	! CLOSE(100)

	! CALL SYSTEM('mkdir '//folder) ! also commented this out
	!CALL SYSTEM('mkdir '//output_fold) ! create output folder
	! OPEN(1,file=folder//'/data01.dat') ! commented this line out to stop making this file!
!==========================================================================================!
	END SUBROUTINE
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!        VARIABLES                                                           !!!!!!!!
!!!!!!!!        x(1)  -> membrane potential (mV)                                    !!!!!!!!
!!!!!!!!        x(2)  -> AMPA conductance (g_leak)                                  !!!!!!!!
!!!!!!!!        x(3)  -> GABA_A conductance (g_leak)                                !!!!!!!!
!!!!!!!!        x(5)  -> filtered output spike train (Hz)                           !!!!!!!!
!!!!!!!!        x(6)  -> short average of x(5)                                      !!!!!!!!
!!!!!!!!        x(7)  -> short average of x(5)*x(5)                                 !!!!!!!!
!!!!!!!!        x(8)  -> long average of x(6)                                       !!!!!!!!
!!!!!!!!        x(9)  -> long average of x(7)                                       !!!!!!!!
!!!!!!!!                                                                            !!!!!!!!
!!!!!!!!        msynw  -> synaptic weights                                          !!!!!!!!
!!!!!!!!                                                                            !!!!!!!!
!!!!!!!!        patt_time -> OU variable                                            !!!!!!!!
!!!!!!!!        inp_patt -> rate envelope for inh. Poisson process                  !!!!!!!!
!!!!!!!!                                                                            !!!!!!!!
!!!!!!!!        activity         -> filtered presynaptic spike trains (Hz)          !!!!!!!!
!!!!!!!!        activity_av      -> short average of activity                       !!!!!!!!
!!!!!!!!        activity_av2     -> average of activity*activity                    !!!!!!!!
!!!!!!!!        activity_av_t    -> long average of activity_av                     !!!!!!!!
!!!!!!!!        activity_av_t2   -> long average of activity_av2                    !!!!!!!!
!!!!!!!!        cross_activity   -> average of x(5)*activity                        !!!!!!!!
!!!!!!!!        cross_activity_t -> long average of cross_activity                  !!!!!!!!
!!!!!!!!        covariance       -> covariance input/output                         !!!!!!!!
!!!!!!!!        norm             -> SD input*SD output (norm for Pearson corr)      !!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!


$ Declare
   SUBROUTINE CrackClosureFactorU (Kmincyc, Kmaxcyc, Kres, U)
!
! Crack closure factor U
! (Shetty and Baker, 1990)
!
! Parameters
   DOUBLE PRECISION, INTENT(IN)    :: Kmincyc  ! Minimum value of the cyclic component of the total stress intensity
   DOUBLE PRECISION, INTENT(IN)    :: Kmaxcyc  ! Maximum value of the cyclic component of the total stress intensity
   DOUBLE PRECISION, INTENT(IN)    :: Kres     ! Mean level of the total stress intensity, due to welding residual stresses
   DOUBLE PRECISION, INTENT(OUT)   :: U        ! Crack closure factor
!
! Declarations
   DOUBLE PRECISION                :: Rs
!
! Check input
   IF (Kmincyc .GT. 0.0D0) STOP 'Incorrect input in Subroutine CrackClosureFactorU: Kmincyc > 0'
   IF (Kmaxcyc .LT. 0.0D0) STOP 'Incorrect input in Subroutine CrackClosureFactorU: Kmaxcyc < 0'
!
! Stress ratio Rs
   Rs = (Kmincyc + Kres) / (Kmaxcyc + Kres)
!
! Crack closure factor U
   IF (Rs .GE. 0.D0) THEN
      U = 1.D0
   ELSE
      U = 1.D0 / (1.D0 - Rs)
   END IF
!
! Einde subroutine
   RETURN
   END


      DOUBLE PRECISION FUNCTION DCPLTK(EM)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 2001-06-18 DCPLTK Krogh  Remove a ' ' inside a floating point num.
C>> 1998-10-29 DCPLTK Krogh  Moved external statement up for mangle.
c>> 1996-03-30 DCPLTK Krogh   Changed MAX to MAXT
C>> 1994-10-27 DCPLTK Snyder  Correct missing type declarations
C>> 1994-10-20 DCPLTK Krogh  Changes to use M77CON
C>> 1994-05-16 DCPLTK Snyder  Make SP and DP codes alike using CHGTYP
C>> 1989-06-16 DCPLTK Snyder  Remove implied DO from DATA stmts for CFT
C>> 1985-08-02 DCPLTK Lawson  Initial code.
C--D replaces "?": ?CPLTK, ?ERM1
C
C     Complete elliptic integral K(EM). Method given by
C     W.J.CODY, Math. of Comp.,Vol.19, (1965), pp. 105-111.
C     Data are taken from Cody's table in reverse order.
C     We are using N = 5 or 9 for single precision and
C     N = 10 for double precision.
C
C     C.L.LAWSON & STELLA CHAN,JPL,1983 JUNE.
C
C     ----------------------------------------------------
C
C     POLY DEGREE     NEGATIVE LOG BASE 10 OF MAX ABS
C                     ERROR OF APPROXIMATION
C
C         N           FOR K           FOR E
C         -           -----           -----
C         5            9.50            9.44
C         9           15.87           15.84
C        10           17.45           17.42
C
C     ----------------------------------------------------
C
      EXTERNAL D1MACH
      DOUBLE PRECISION A(10,3), B(10,3), D1MACH
      DOUBLE PRECISION EM, EMP, FAC, HALF, ONE, S1, S2, U, VL, ZERO
      INTEGER J, M, MAXT
C
      SAVE M, MAXT, FAC
C
C     VL = LOG(4)
      DATA VL/1.3862943611198906188344642429163531361510002687205D0/
C
      DATA ZERO,ONE,HALF / .0D0, 1.D0, .5D0 /
C
      DATA M / 0 /
C
      DATA A / 6.63980111468D-03, 2.59628884526D-02,
     *         2.37612248576D-02, 3.15594316275D-02,
     *         9.65786196226D-02, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,

     *         3.00725199036864838D-04, 3.96847090209897819D-03,
     *         1.07959904905916349D-02, 1.05899536209893585D-02,
     *         7.51938672180838102D-03, 8.92664629455646620D-03,
     *         1.49420291422820783D-02, 3.08851730018997099D-02,
     *         9.65735903017425285D-02, 0.0D0,

     *         1.3930878570066467279D-04,2.2966348983969586869D-03,
     *         8.0030039806499853708D-03,9.8489293221768937682D-03,
     *         6.8479092826245051197D-03,6.1796274460533176084D-03,
     *         8.7898018745550646778D-03,1.4938013532687165242D-02,
     *         3.0885146271305189866D-02,9.6573590280856255384D-02/
C
      DATA B / 1.84723416323D-03, 1.87516602769D-02,
     *         4.49838755399D-02, 7.01487577829D-02,
     *         1.24999295975D-01, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,

     *         6.66317524646073151D-05, 1.72161470979865212D-03,
     *         9.28116038296860419D-03, 2.06902400051008404D-02,
     *         2.95037293486887130D-02, 3.73355466822860296D-02,
     *         4.88271550481180099D-02, 7.03124954595466082D-02,
     *         1.24999999997640658D-01, 0.0D0,

     *         2.9700280966555612066D-05,9.2155463496324984638D-04,
     *         5.9739042991554291551D-03,1.5530941631977203877D-02,
     *         2.3931913323110790077D-02,3.0124849012898930266D-02,
     *         3.7377739758623604144D-02,4.8828041906862397978D-02,
     *         7.0312499739038352054D-02,1.2499999999990808051D-01/
C
      IF (M .EQ. 0) THEN
        IF (D1MACH(3) .LT. 6.31D-17) THEN
          M = 3
          MAXT = 10
C          -LOG10(6.31D-17) = 16.2
        ELSE IF (D1MACH(3) .LT. 6.31D-9) THEN
C          -LOG10(6.31D-9) = 8.2
          M = 2
          MAXT = 9
        ELSE
          M = 1
          MAXT = 5
        END IF
        FAC = ONE + 2 * D1MACH(3)
      END IF
      IF (EM .GE. ONE) THEN
        CALL DERM1('DCPLTK',1,0,'INFINITE VALUE WHEN EM .EQ. 1' //
     *             ' AND UNDEFINED FOR EM .GT. 1','EM',EM,'.')
        U = ZERO
      ELSE IF (EM .LT. ZERO) THEN
        CALL DERM1('DCPLTK',2,0,'UNDEFINED FOR EM .LT. ZERO',
     *             'EM',EM,'.')
        U = ZERO
      ELSE
        EMP = HALF + (HALF- EM)
        S1 = EMP * A(1,M)
        S2 = EMP * B(1,M)
        DO 100 J = 2, MAXT
          S1 = (S1 + A(J,M)) * EMP
          S2 = (S2 + B(J,M)) * EMP
  100   CONTINUE
        U = VL + S1 + LOG(ONE/EMP) * (HALF + S2)
      END IF
C
      DCPLTK = U * FAC
      RETURN
C
      END


      SUBROUTINE CSCAL(N,CA,CX,INCX)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1994-11-11 CSCAL  Krogh   Declared all vars.
C>> 1985-08-02 CSCAL  Lawson  Initial code.
C
C     REPLACE COMPLEX CX BY COMPLEX CA*CX.
C     FOR I = 0 TO N-1, REPLACE CX(1+I*INCX) WITH  CA * CX(1+I*INCX)
C
      INTEGER N, NS, INCX, I
      COMPLEX CA,CX(*)
C
      IF(N .LE. 0) RETURN
      NS = N*INCX
          DO 10 I = 1,NS,INCX
          CX(I) = CA*CX(I)
   10     CONTINUE
      RETURN
      END


module mod_sysnoise

 !===================================================================================85
 !---------------------------- DESCRIPTION ------------------------------------------85
 !
 !
 !
 !          Module  name:
 !                         'mod_sysnoise'
 !
 !          Purpose:
 !                   Radar system noise temperature in units of Kelvin (K)
 !                   Sky noise temperature in units of Kelvin (K).
 !
 !          History:
 !                        Date: 18-10-2017
 !                        Time: 16:37 GMT+2
 !
 !          Version:
 !
 !                      Major: 1
 !                      Minor: 0
 !                      Micro: 0
 !
 !          Author:
 !                  Bernard Gingold
 !
 !          References:
 !
 !                      Doppler Radar and Weather Observations
 !                      Richard L. Dvorak, Dusan S. Zrnic
 !
 !
 !
 !          E-mail:
 !
 !                      beniekg@gmail.com
 !==================================================================================85

 ! Tab:5 col - Type and etc.. definitions
 ! Tab:10,11 col - Type , function and subroutine code blocks.
    implicit none
    private
    use module_kinds
    public :: compute_sys_noise

    !=====================================================59
    !  File and module information:
    !  version,creation and build date, author,description
    !=====================================================59

    ! Major version
    integer(I32P), parameter :: MOD_SYSNOISE_MAJOR = 1

    ! Minor version
    integer(I32P), parameter :: MOD_SYSNOISE_MINOR = 0

    ! Micro version
    integer(I32P), parameter :: MOD_SYSNOISE_MICRO = 0

    ! Module full version
    integer(I32P), parameter :: MOD_SYSNOISE_FULLVER = 1000*MOD_SYSNOISE_MAJOR+100*MOD_SYSNOISE_MINOR+ &
                                                       10*MOD_SYSNOISE_MICRO
    ! Module/file creation date
    character(*),  parameter :: MOD_SYSNOISE_CREATE_DATE = "18-10-2017 16:37 +00200 (WED 18 OCT 2017 GMT+2)"

    ! Module build date (should be set after successful build date/time)
    character(*),  parameter :: MOD_SYSNOISE_BUILD_DATE = " "

    ! Module author info
    character(*),  parameter :: MOD_SYSNOISE_AUTHOR = "Programmer: Bernard Gingold, e-mail: beniekg@gmail.com"

    ! Module short description
    character(*),  parameter :: MOD_SYSNOISE_DESCRIPT = " Radar system noise temperature."

    contains

    subroutine compute_sys_noise(Tsy,Ts,Lr,Ll,L1,Tr,Tl,T1,TempR,nx)
          implicit none
          real(R64P), dimension(nx), intent(out) :: Tsy
!DIR$     ASSUME_ALIGNED Tsy:32
          real(R64P), dimension(nx), intent(in)  :: Ts,Lr,Ll,L1,Tr, &
                                                    Tl,T1,TempR
!DIR$     ASSUME_ALIGNED Ts:32
!DIR$     ASSUME_ALIGNED Lr:32
!DIR$     ASSUME_ALIGNED Ll:32
!DIR$     ASSUME_ALIGNED L1:32
!DIR$     ASSUME_ALIGNED Tr:32
!DIR$     ASSUME_ALIGNED Tl:32
!DIR$     ASSUME_ALIGNED T1:32
!DIR$     ASSUME_ALIGNED TempR:32
          integer(I32P) :: nx
          ! Locals
          real(R64P) :: inv1,inv2,inv3,inv4, &
                        term1,term2,term3,term4
          integer(I32P) :: i
          ! Start of executable statements
          do i = 1, nx
              inv1  = (Lr(i)*Ll(i)*L1(i))**-1._R64P
              term1 = Ts(i)*inv1
              inv2  = (Ll(i)*L1(i))**-1._R64P
              term2 = TempR*inv2
              inv3  = 1._R64P-(Lr(i)**-1._R64P)
              term2 = term2*inv3
              inv4 = 1._R64P-(Ll(i)**-1._R64P)
              term3 = Tl(i)*(L1(i)**-1._R64P)*inv4
              term4 = T1(i)*(1._R64P-(L1(i)**-1.R64P)+TempR
              Tsy(i) = term1+term2+term3+term4
            end do
    end subroutine

    pure function compute_sky_noise(Ts,alpha,nur,Tg) result(snoise)
          implicit none
          real(R64P), intent(in) :: Ts,alpha,nur,Tg
          ! Locals
          real(R64P) :: term1,term2,term3,snoise
          ! Start of executable statements
          term1 = Ts*(1._R64P-alpha)
          term2 = alpha*(1._R64P-nur)*Tg
          term3 = Ts*alpha*nur
          snoise = ter1+term2+term3
    end function

end module mod_sysnoise


!*****************************************************************************************
!> author: Jacob Williams
!
!  Kind definitions for the other modules.

	module kind_module

	use iso_fortran_env

	implicit none

	private

	! default real precision:

	!integer,parameter,public :: wp = real32   !! single precision
	integer,parameter,public :: wp = real64    !! double precision [default]
	!integer,parameter,public :: wp = real128  !! quad precision

	end module kind_module
!*****************************************************************************************


! { dg-do run }
!
! Check that we can use SHAPE with optional kind argument
!
program test
   implicit none
   real, allocatable :: x(:,:)

   allocate(x(2,5))
   if (any(shape(x) /= [ 2, 5 ])) call abort
   if (any(shape(x,kind=1) /= [ 2, 5 ])) call abort
   if (any(shape(x,kind=2) /= [ 2, 5 ])) call abort
   if (any(shape(x,kind=4) /= [ 2, 5 ])) call abort
   if (any(shape(x,kind=8) /= [ 2, 5 ])) call abort
end


!     ( Last modified on 23 Dec 2000 at 22:01:38 )
PROGRAM COBMA
!
!  COBYLA test driver for problems derived from SIF files.
!
!  A. R. Conn and Ph. Toint (based upon Nick Gould's vf13ma.f)
!  January 1995.
!
!  Fortran 90/95 version, D. Orban, November 2006
!
Use CUTEr_precis
Use CUTEr_interfaces

 INTEGER ::         NMAX, MMAX, M, N, MAXFUN, MCON, LW, LIW
 INTEGER ::         IPRINT, I, MGEQ, INDR, INPUT, IOUT, NFIX
! PARAMETER      ( LW   = NMAX * ( 3 * NMAX + 2 * MMAX + 11 )
!     *                        + 4 * MMAX + 6  )
!      PARAMETER      ( LIW  = NMAX + 1 )
 INTEGER, Dimension(:), Allocatable :: IW !( LIW )

 Real( Kind = wp ), Dimension(:), Allocatable :: X, BL, BU, C, CL, CU, W
 Real( Kind = wp ) :: RHOBEG, RHOEND, F
 Real( Kind = 1.0E+0 ), Dimension(2) :: CPU
 Real( Kind = 1.0E+0 ), Dimension(7) :: CALLS

!S    REAL             X( NMAX ), BL( NMAX ), BU( NMAX ),
!D    DOUBLE PRECISION X( NMAX ), BL( NMAX ), BU( NMAX ),
!     *                 C( MMAX ), CL( MMAX ), CU( MMAX ),
!     *                 W( LW ), RHOBEG, RHOEND, F
!      REAL             CPU( 2 ), CALLS( 7 )

 Logical, Dimension(:), Allocatable :: EQUATN, LINEAR
 Character( Len = 10 ), Dimension(:), Allocatable :: VNAME, CNAME
 Character( Len = 10 ) :: PNAME
 Integer, Parameter :: INPUT = 55, INDR = 46, IOUT = 6

!      LOGICAL          EQUATN( MMAX ), LINEAR( MMAX )
!      CHARACTER * 10   PNAME, VNAME( NMAX ), CNAME( MMAX )

!      PARAMETER      ( INPUT = 55, INDR = 46, IOUT = 6 )
!S    REAL             BIGINF
!D    DOUBLE PRECISION BIGINF
!S    PARAMETER      ( BIGINF = 9.0E+19 )
!D    PARAMETER      ( BIGINF = 9.0D+19 )
      COMMON / FCOBFN /  BL, BU, CL, CU, MGEQ, MCON
!
!  Open the relevant file.
!
      OPEN ( INPUT, FILE = 'OUTSDIF.d', FORM = 'FORMATTED',
     *       STATUS = 'OLD' )
      REWIND INPUT
!
!  Set up the data structures necessary to hold the problem functions.
!
      CALL CSETUP ( INPUT, IOUT, N, MCON, X, BL, BU, NMAX, EQUATN,
     *              LINEAR, C, CL, CU, MMAX, .TRUE., .FALSE., .FALSE. )
      CLOSE ( INPUT )
!
!  Count the number of general equality constraints and ignore them by
!  shifting the remaining constraints at the beginning of the constraints' list
!
      MGEQ = 0
      DO 20 I = 1, MCON
         IF ( EQUATN( I ) ) MGEQ = MGEQ + 1
   20 CONTINUE
      IF ( MGEQ .GT. 0 ) THEN
         WRITE( 6, 3090 ) MGEQ
         DO 30 I = MCON, MGEQ + 1, -1
            CU( I - MGEQ ) = CU( I )
            CL( I - MGEQ ) = CL( I )
   30    CONTINUE
      END IF
      M = MCON - MGEQ
!
!  If constraints have both lower and upper bounds, they have to be
!  included twice!
!
      DO 40 I = 1, MCON - MGEQ
         IF ( CL( I ) .GT. - BIGINF .AND.
     *        CU( I ) .LT.   BIGINF ) M = M + 1
   40 CONTINUE
!
!  Include any simple bounds.
!
      NFIX = 0
      DO 50 I = 1, N
         IF ( BL( I ) .EQ.  BU( I ) ) THEN
            NFIX = NFIX + 1
         ELSE
            IF ( BL( I ) .GT. - BIGINF ) M = M + 1
            IF ( BU( I ) .LT.   BIGINF ) M = M + 1
         END IF
   50 CONTINUE
      IF ( NFIX .GT. 0 ) WRITE( 6, 3020 ) NFIX
!
      IF ( M .GT. MMAX ) THEN
         IF ( IOUT .GT. 0 )
     *      WRITE( IOUT, 3000 ) 'EQUATN', 'MMAX  ', M - MMAX
         STOP
      END IF
!
!  Open the Spec file for the method.
!
      OPEN( INDR, FILE = 'COBYLA.SPC', FORM = 'FORMATTED',
     *      STATUS = 'OLD')
      REWIND INDR
!
!  Read input Spec data.
!
!   RHOBEG = the size of the simplex initially
!   RHOEND = the size of the simplex at termination
!   MAXFUN = the maximum number of function calls allowed.
!   IPRINT   should be set to 0, 1, 2 or 3, it controls the amount of printing.
!
!  Set up algorithmic input data.
!
      READ ( INDR, 1000 ) RHOBEG, RHOEND, MAXFUN, IPRINT
      CLOSE ( INDR )
!
!  Evaluate the objective function and constraints.
!
      CALL CALCFC( N, X, F, C )
!
!  Perform the minimization.
!
      CALL COBYLA( N, M, X, RHOBEG, RHOEND, IPRINT, MAXFUN, W, IW)
      CALL CREPRT ( CALLS, CPU )
!
      CALL CNAMES( N, MCON, PNAME, VNAME, CNAME )
      CALL CALCFC( N, X, F, C )
      WRITE( 6, 2110 ) ( I, VNAME( I ), X( I ), BL( I ), BU( I ),
     *                      I = 1, N )
      IF ( MCON .GT. 0 ) WRITE( 6, 2120 ) ( I, CNAME( I ), C( I ),
     *     CL( I ), CU( I ), LINEAR( I ), I = 1, MCON )
      WRITE( 6, 2000 ) PNAME, N, MCON, CALLS(1), CALLS(5), F,
     *     CPU(1), CPU(2)
      STOP

!
!  Non-executable statements
!
 2000 FORMAT( /, 24('*'), ' CUTEr statistics ', 24('*') //
     *    ,' Code used               :  COBYLA ',  /
     *    ,' Problem                 :  ', A10,    /
     *    ,' # variables             =      ', I10 /
     *    ,' # constraints           =      ', I10 /
     *    ,' # objective functions   =        ', F8.2 /
     *    ,' # constraints functions =        ', F8.2 /
     *    ,' Final f                 = ', E15.7 /
     *    ,' Set up time             =      ', 0P, F10.2, ' seconds' /
     *     ' Solve time              =      ', 0P, F10.2, ' seconds' //
     *     66('*') / )
 1000 FORMAT( D12.4, /, D12.4, /,I6, /, I6 )
 2110 FORMAT( /, ' The variables:', /,
     *        '     I name          value    lower bound upper bound',
     *        /, ( I6, 1X, A10, 1P, 3D12.4 ) )
 2120 FORMAT( /, ' The constraints:', /,
     *        '     I name          value    lower bound upper bound',
     *        ' linear? ',
     *        /, ( I6, 1X, A10, 1P, 3D12.4, 5X, L1 ) )
 3000 FORMAT( /,'  ** Program CSETUP: array length ', A6, ' too small.',
     *        /,'  -- Miminimization abandoned.',
     *        /,'  -- Increase the parameter ', A6, ' by at least ', I8,
     *          ' and restart.'  )
 3020 FORMAT( /,'  ** Warning from COBMA. **',
     *        /,'     In the problem as stated , ', I6,
     *          ' variables are fixed: they are changed to free.' )
 3090 FORMAT( /,'  ** Warning from COBMA. **',
     *        /,'     The problem as stated includes ', I6,
     *          ' equality constraints: they are ignored ' )
!
!  End of COBMA.
!
      END
      SUBROUTINE CALCFC( N, X, F, C )
!
!  Evaluates the objective function value in a format compatible with COBYLA,
!  but using the CUTEr tools.
!
!  A. R. Conn and Ph. Toint
!  January 1995.
!
      INTEGER            NMAX, MMAX
!TOY  PARAMETER        ( NMAX =  10, MMAX =  10 )
!MED  PARAMETER        ( NMAX = 100, MMAX = 100 )
!BIG  PARAMETER        ( NMAX = 500, MMAX = 500 )
!CUS  PARAMETER        ( NMAX = 200, MMAX = 100 )
      INTEGER            N, MGEQ, MCON, I, MT
!S    REAL               F, X( N ), C( MMAX ), BL( NMAX ), BU( NMAX )
!D    DOUBLE PRECISION   F, X( N ), C( MMAX ), BL( NMAX ), BU( NMAX )
!S    REAL               CL( MMAX ), CU( MMAX )
!D    DOUBLE PRECISION   CL( MMAX ), CU( MMAX )
      COMMON /FCOBFN/    BL, BU, CL, CU, MGEQ, MCON
!
!S    REAL               BIGINF
!D    DOUBLE PRECISION   BIGINF
!S    PARAMETER        ( BIGINF = 9.0E+19 )
!D    PARAMETER        ( BIGINF = 9.0D+19 )
!
!  Evaluate the objective function and constraints.
!
      CALL CFN ( N, MCON, X, F, MMAX, C )
!
!  If there are equality constraints, ignore them
!  and shift all the inequality constraint values.
!
      IF ( MGEQ .GT. 0 ) THEN
         DO 10 I = MCON, MGEQ + 1, - 1
            C( I - MGEQ ) = C( I )
   10    CONTINUE
      END IF
!
!  If constraints have both lower and upper bounds, they have to
!  be included twice! Reverse the signs of less-than-or-equal-to
!  constraints.
!
      MT = MCON - MGEQ + 1
      DO 40 I = 1, MCON - MGEQ
         IF ( CL( I ) .GT. - BIGINF .AND.
     *        CU( I ) .LT.   BIGINF ) THEN
            C( I )  = CU( I ) - C( I )
            C( MT ) = C( I ) - CL( I )
            MT      = MT + 1
         ELSE IF ( CL( I ) .GT. - BIGINF ) THEN
            C( I )  = C( I ) - CL( I )
         ELSE IF ( CU( I ) .LT.   BIGINF ) THEN
            C( I )  = CU( I ) - C( I )
         END IF
   40 CONTINUE
!
!  Include any simple bounds, including fixed variables.
!
      DO 50 I = 1, N
         IF ( BL( I ) .NE.  BU( I ) ) THEN
            IF ( BL( I ) .GT. - BIGINF ) THEN
               C( MT ) = X( I ) - BL( I )
               MT      = MT + 1
            END IF
            IF ( BU( I ) .LT.   BIGINF ) THEN
               C( MT ) = BU( I ) - X( I )
               MT      = MT + 1
            END IF
         END IF
   50 CONTINUE
      RETURN
!
!  End of CALCFC.
!
      END


program main
    use FEMDomainClass
    use FEMIfaceClass
    use DiffusionEquationClass
    use FiniteDeformationClass
    use MultiPhysicsIfaceClass
    use PostProcessingClass
    implicit none

    type(FEMDomain_),target::rootdomain1,rootdomain2
    type(FEMIface_ ),target::iface12
    type(DiffusionEq_) ::field1
    type(FiniteDeform_)::field2

    character*70 :: InProjName1,InProjName2,gmsh,GaussJordan,Deformation,BiCGSTAB
    integer :: i,j,Step
    real(8) :: time

    gmsh="Gmsh"
    GaussJordan="GaussJordan"
    BiCGSTAB="BiCGSTAB"
    Deformation="Deformation"

    ! ###### Read Infile info ###################
    print *, "Import Project Name (Diffusion) is : "
    !read *, InProjName1
    InProjName1="difftest3d"
    print *, trim(InProjName1),".scf"
    print *, "Import Project Name (Deformation) is : "
    !read *, InProjName2
    InProjName2="finitedtest"
    print *, trim(InProjName2),".scf"
    print *, "Time duration (sec.): "
    read *, time
    ! ###### Read Infile info ###################

    ! ###### Import Objects ###################
    call ImportFEMDomainDiff(rootdomain1,OptionalProjectName=InProjName1)
    field1%FEMDomain => rootdomain1
    field1%dt=time/dble(field1%FEMDomain%ControlPara%Timestep)

    call ImportFEMDomainFiDe(rootdomain2,OptionalProjectName=InProjName2)
    field2%FEMDomain => rootdomain2
    field2%dt=time/dble(field2%FEMDomain%ControlPara%Timestep)
    ! ###### Import Objects ###################

    rootdomain1%Mesh%NodCoord(:,1:2)=rootdomain1%Mesh%NodCoord(:,1:2)+3.0d0

    call GetFEMIface(rootdomain1,rootdomain2,iface12)

end program


! #define DEBUG
      subroutine DM_dipole_dipole(rb, qb, eta_in, errlim, apos, nat,
     $     Zeff, eps, qph, dmat)
c*****************************************************************
c     Find the lattice contribution to the dynamical matrix.
c     Uses Ewald transformation to split the lattice sums into
c     rapidly convergent real and reciprocal space summations.
c     Works with effective charges given as tensors, includes
c     dielectric screening due to electronic polarization.
c
c   INPUT:
c     rb - real-space basis;
c     qb - reciprocal space basis;
c     eta - parameter for the Ewald summations;
c              use find_Ewald_eta_screened to determine optimal value
c     errlim - requested accuracy;
c     nat - number of atoms in the unit cell
c     apos - atomic position in the unit cell;
c     Zeff - Born effective charge tensorse;
c     eps - dielectric matrix;
c     qph - phonon wave vector;
c
c   OUTPUT:
c     dmat - electrostatic contribution to the dynamical matrix,
c            it should be divided by the lattice constant to get
c            the same normalization as the DMs calculated by lrx
c
c     This implementation closely follows Gonze, X., & Lee, C. (1997).
c     "Dynamical matrices, born effective charges, dielectric permittivity
c     tensors, and interatomic force constants from density-functional
c     perturbation theory." Physical Review B, 55(16), 10355--10368.
c
c  DATE: Sun Jan  1 11:45:23 PST 2012
c*****************************************************************
      implicit none

      integer, intent(IN)                    :: nat
      real*8, dimension(3,3), intent(IN)     :: rb, qb, eps
      real*8, intent(IN)                     :: eta_in, errlim
      real*8, dimension(3,nat), intent(IN)   :: apos
      real*8, dimension(3,3,nat), intent(IN) :: Zeff
      real*8, dimension(3), intent(IN)       :: qph
      complex*16, dimension(3,nat,3,nat), intent(OUT) :: dmat

      integer i1, i2, i3, n1, n2, n3, j1, j2, m, n, j
      real*8 pi, tpi, piroot, omega, x, x1, x2, x3, y, etasq, ekmax,
     $     G(3), dtau(3), Gpq(3), g2, Gpq2, rsq, rmod, dr(3), vr(3),
     $     Delta(3), tpi2, taumax, eps_inv(3,3), deteps
      complex*16 cz, cfac, tdm(3,3)
      complex*16, dimension(:,:,:,:), allocatable    :: dmat0
      complex*16, dimension(:), allocatable        :: czz
      real*8 eta

c     LAPACK related variables
      integer lwork
      parameter (lwork=30)
      integer info
      real*8 teps(3,3), evr(3), evi(3), vleft(3,3), vright(3,3),
     $     work(lwork)

      real*8 tripl, derfc
      external tripl, derfc

      eta=eta_in

      deteps = (eps(1,1)*(eps(2,2)*eps(3,3)-eps(2,3)*eps(3,2))
     $     - eps(2,1)*(eps(1,2)*eps(3,3)-eps(1,3)*eps(3,2))
     $     + eps(3,1)*(eps(1,2)*eps(2,3)-eps(2,2)*eps(1,3)) )

      eps_inv(1,1) = eps(2,2)*eps(3,3)-eps(2,3)*eps(3,2)
      eps_inv(2,1) = eps(2,3)*eps(3,1)-eps(2,1)*eps(3,3)
      eps_inv(3,1) = eps(2,1)*eps(3,2)-eps(2,2)*eps(3,1)
      eps_inv(1,2) = eps(1,3)*eps(3,2)-eps(1,2)*eps(3,3)
      eps_inv(2,2) = eps(1,1)*eps(3,3)-eps(1,3)*eps(3,1)
      eps_inv(3,2) = eps(1,2)*eps(3,1)-eps(1,1)*eps(3,2)
      eps_inv(1,3) = eps(1,2)*eps(2,3)-eps(1,3)*eps(2,2)
      eps_inv(2,3) = eps(1,3)*eps(2,1)-eps(1,1)*eps(2,3)
      eps_inv(3,3) = eps(1,1)*eps(2,2)-eps(1,2)*eps(2,1)

      eps_inv = eps_inv / deteps

#ifdef DEBUG
      print *, 'input eta=', eta
#ifdef READPARAMETER
      open (unit=99, file='eta.txt', status='old', action='read')
      read(99, *), eta
      close(99)
      print *, 'read eta=', eta
#endif
      print '(a/3(3f12.4/))', ' Dielectric matrix:', eps
      print '(a/3(3f12.4/))', ' Inverse dielectric matrix:', eps_inv
      print '(a,f12.4)', ' Determinant of dielectric matrix =', deteps
      print '(3f12.6)', MATMUL( eps, eps_inv )
#endif

      etasq = eta*eta
      pi = 4d0*atan(1d0)
      piroot = sqrt(pi)
      tpi = 2d0*pi
      tpi2 = tpi*tpi
      omega=abs(tripl(rb(1,1), rb(1,2), rb(1,3)))

      allocate( dmat0(3,nat,3,nat) )

      dmat = (0d0, 0d0)
      dmat0 = (0d0, 0d0)

      teps = eps
!      call LA_DGEEV('N','V',3,teps,3,evr,evi,vleft,3,vright,3,
      call DGEEV('N','V',3,teps,3,evr,evi,vleft,3,vright,3,
     $     work,lwork,info)
      if( info /= 0 ) print *, 'DGEEV error: info=', info
#ifdef DEBUG
      print '(2x,a30)', 'Eigenvalues and eigenvectors:'
      do j = 1, 3
         print '(2f10.4,5x,3f10.4)', evr(j), evi(j), vright(:,j)
      end do
#endif

      x = 2d0 * eta * sqrt(-log(errlim))
      y = sqrt(dot_product(qph,qph))
      ekmax = MINVAL(1d0/evr)*(x+y)**2 / 2d0
      call gbox(ekmax, 1d0, qb, n1, n2, n3)

      ALLOCATE( czz(nat) )

#ifdef DEBUG
      print '(a,3i4)', 'DM_dipole_dipole: recip-space sums are over ',
     $     n1, n2, n3
#ifdef READPARAMETER
      open (unit=99, file='nq.txt', status='old', action='read')
      read(99, *), n1, n2, n3
      close(99)
#endif
#endif

      do i1=-n1,n1
         do i2=-n2,n2
            do i3=-n3,n3

               G = i1*qb(:,1) + i2*qb(:,2) + i3*qb(:,3)
               Gpq = G + qph
               G2   = dot_product(G, MATMUL(eps,G) )
               Gpq2 = dot_product(Gpq, MATMUL(eps, Gpq))

               do m=1,nat
                  x = tpi*(G(1)*apos(1,m) + G(2)*apos(2,m)
     $                 + G(3)*apos(3,m))
                  czz(m) = dcmplx( cos(x), sin(x) )
               end do

c     Q /= 0 contribution.
               if (Gpq2 > 1d-25) then
                  do m=1,nat
                     do n=1,nat
                        cfac = exp(-tpi2*Gpq2/(4d0*etasq)) / Gpq2
                        do j1=1,3
                           do j2=1,3
                              tdm(j1,j2) = cfac * czz(m) * CONJG(czz(n))
     $                             * Gpq(j1) * Gpq(j2)
                           end do
                        end do
                        dmat(:,m,:,n) = dmat(:,m,:,n) + tdm
                     end do
                  end do
#ifdef DEBUG
               if ((i1==n1).and.(i2==n2).and.(i3==n3)) then
                  print *, 'recip fac=', abs(cfac)
               end if
#endif
               end if

c     Q=0 contribution
               if (G2 > 1d-25) then
                  do m=1,nat
                     do n=1,nat
                        cfac = czz(m) * CONJG(czz(n)) *
     $                       exp(-tpi2*G2/(4d0*etasq)) / G2
                        do j1=1,3
                           do j2=1,3
                              tdm(j1,j2) = cfac * G(j1)*G(j2)
                           enddo
                        enddo
                        dmat0(:,m,:,n) = dmat0(:,m,:,n) + tdm
                     end do
                  end do
               end if

            enddo
         enddo
      enddo
      dmat = (4d0*pi/omega) * dmat
      dmat0 = (4d0*pi/omega) * dmat0
      DEALLOCATE( czz )

!#ifdef DEBUG
!C test hermitian
!      print *, 'after recip sum testing dmat'
!      call diff_hermitian(nat*3, dmat)
!      print *, 'testing dmat0'
!      call diff_hermitian(nat*3, dmat0)
!#endif

c   Debugging section for testing reciprocal space loop by comparing
c   with the recip space loop in DMewald routine from the lrx code
c$$$      do m = 1, nat
c$$$         do n = 1, nat
c$$$            dmat(:,m,:,n) = MATMUL( Zeff(:,:,m),
c$$$     $                              MATMUL( dmat(:,m,:,n),
c$$$     $                                      TRANSPOSE(Zeff(:,:,n))
c$$$     $                              )
c$$$     $                      )
c$$$            dmat0(:,m,:,n) = MATMUL( Zeff(:,:,m),
c$$$     $                              MATMUL( dmat0(:,m,:,n),
c$$$     $                                      TRANSPOSE(Zeff(:,:,n))
c$$$     $                              )
c$$$     $                      )
c$$$         end do
c$$$      end do
c$$$
c$$$      do m = 1, nat
c$$$         do n = 1, nat
c$$$            dmat(:,m,:,m) = dmat(:,m,:,m) - dmat0(:,m,:,n)
c$$$         end do
c$$$      end do
c$$$
c$$$      deallocate( dmat0 )
c$$$      return

      taumax = 0d0
      do m=1,nat
         do n=1,m
            dr = apos(:,m) - apos(:,n)
            rsq = dot_product(dr, MATMUL(eps_inv, dr))
            taumax = max(taumax, rsq)
         enddo
      enddo
      x = sqrt(-log(errlim)) / eta
      y = sqrt(taumax)
      ekmax = MINVAL(evr) * tpi2 * (x+y)**2 / 2d0
      call gbox(ekmax, 1d0, rb, n1, n2, n3)

#ifdef DEBUG
      print '(a,3i4)', 'DM_dipole_dipole: real-space sums over',n1,n2,n3
#ifdef READPARAMETER
      open (unit=99, file='nr.txt', status='old', action='read')
      read(99, *), n1, n2, n3
      close(99)
#endif
#endif

      do i1=-n1,n1
         do i2=-n2,n2
            do i3=-n3,n3

               vr = i1*rb(:,1) + i2*rb(:,2) + i3*rb(:,3)

               do m=1,nat
                  do n=1,nat
                     if( n/=m .or. i1/=0 .or. i2/=0 .or. i3/=0 ) then

                        dr = vr + apos(:,m) - apos(:,n)
                        Delta = MATMUL(eps_inv, dr)
                        rsq = dot_product(Delta, dr)
                        rmod = sqrt(rsq)

c     This line should work for the "standard" definition of dynamical matrix
c     without the additional factor exp[iq(a_i-a_j)].
!                        x = tpi * dot_product(qph, vr)
                        x = tpi * dot_product(qph, dr)
                        cz = dcmplx(cos(x), -sin(x))

                        x1 = derfc(eta*rmod) / (eta*rmod)**3
                        x2 = (2d0/piroot) * exp(-rsq*etasq)
                        x3 = x2 / (eta*rmod)**2

                        do j1=1,3
                           do j2=1,3
                              tdm(j1,j2) = - eps_inv(j1,j2) * (x1+x3)
     $                             + (Delta(j1)*Delta(j2)/rsq)
     $                                 * ( 3d0*(x1+x3) + 2d0*x2)
                           enddo
                        enddo
                        tdm = cz * eta**3 * tdm / sqrt(deteps)

                        dmat(:,m,:,n) = dmat(:,m,:,n) - tdm

                        do j1=1,3
                           do j2=1,3
                              tdm(j1,j2) = - eps_inv(j1,j2) * (x1+x3)
     $                             + (Delta(j1)*Delta(j2)/rsq)
     $                                 * ( 3d0*(x1+x3) + 2d0*x2)
                           enddo
                        enddo
                        tdm = eta**3 * tdm / sqrt(deteps)

                        dmat0(:,m,:,n) = dmat0(:,m,:,n) - tdm

#ifdef DEBUG
               if ((i1==n1).and.(i2==n2).and.(i3==n3)
     $            .and.(m==1).and.(n==1)) then
             write(*,'(A,4E9.2)') '|fac|=', maxval(abs(tdm)),x1,x2,x3
               end if
               if ((i1==0).and.(i2==0).and.(i3==0)
     $            .and.(m==1).and.(n==2)) then
       write(*,'(A,5E9.2)') '|fac 1-2|=', maxval(abs(tdm)),x1,x2,x3,rmod
               end if
#endif
                     end if
                  enddo
               enddo

            enddo
         enddo
      enddo

!#ifdef DEBUG
!C test hermitian
!      print *, 'after real space sum testing dmat'
!      call diff_hermitian(nat*3, dmat)
!      print *, 'testing dmat0'
!      call diff_hermitian(nat*3, dmat0)
!#endif

c     Constant term for the limiting contribution. Third term in Eq.(73)
      do m = 1, nat
         dmat(:,m,:,m) = dmat(:,m,:,m) - (4d0/(3d0*piroot)) * eta**3
     $        * eps_inv / sqrt(deteps)
         dmat0(:,m,:,m) = dmat0(:,m,:,m) - (4d0/(3d0*piroot)) * eta**3
     $        * eps_inv / sqrt(deteps)
      end do

! Eq.(72), \hat{C} = linear transform of \bar{C}
! Note the typo in Eq.(72) RHS, should be C_{\alpha' \beta'}
      do m = 1, nat
         do n = 1, nat
            dmat(:,m,:,n) = MATMUL( Zeff(:,:,m),
     $                              MATMUL( dmat(:,m,:,n),
     $                                      TRANSPOSE(Zeff(:,:,n))
     $                              )
     $                      )
            dmat0(:,m,:,n) = MATMUL( Zeff(:,:,m),
     $                              MATMUL( dmat0(:,m,:,n),
     $                                      TRANSPOSE(Zeff(:,:,n))
     $                              )
     $                      )
         end do
      end do

!#ifdef DEBUG
!C test hermitian
!      print *, 'after Z* testing dmat'
!      call diff_hermitian(nat*3, dmat)
!      print *, 'testing dmat0'
!      call diff_hermitian(nat*3, dmat0)
!#endif

c     Enforce acoustic sum rule.
      do m = 1, nat
         do n = 1, nat
            dmat(:,m,:,m) = dmat(:,m,:,m) -  dmat0(:,m,:,n)
!C      dmat(:,m,:,m) = dmat(:,m,:,m)-(dmat0(:,m,:,n)+dmat0(:,n,:,m))/2.0
         end do
      end do

#ifdef DEBUG
C test hermitian
      print *, 'after ASR testing dmat'
      call diff_hermitian(nat*3, dmat)
#endif

#ifdef DEBUG

C test ASR
!      print *, 'DEBUG q=', sqrt(dot_product(qph,qph))
!      if (sqrt(dot_product(qph,qph))<1E-4) then
!         print *, 'testing ASR'
!      do j1=1, 3
!         do j2=1, 3
!            do m=1, nat
!               cfac=(0,0)
!               do n=1, nat
!                  cfac=cfac+ dmat(j1, m, j2, n)
!               end do
!               if (abs(cfac)>1E-7) then
!            write(*,'(A,3I4,2F12.8)'), 'ERROR in ASR m=', j1,j2,m,cfac
!               end if
!            end do
!         end do
!      end do
!      end if
!
!      open (unit = 1, file = "dmat.dat")
!      do n=1,nat
!         do j2=1,3
!            do m=1,nat
!               do j1=1,3
!                  write(1, *) dmat(j1,m,j2,n)
!               end do
!            end do
!         end do
!      end do
!      close(1)

      open(unit = 10, file='dmat.bin',form='unformatted')  ! create a new file, or overwrite an existing on
      write(10) dmat
      close(10) ! close the file
#endif

      deallocate( dmat0 )

      return
      end

#ifdef DEBUG
      subroutine diff_hermitian(size, mat)
      implicit none

      integer, intent(IN)                    :: size
      complex*16, intent(IN)     :: mat(size,size)

      integer i, j, count, maxcount
      real*8 diff

      maxcount=10
      count=0
      do i=1,size
         do j=i+1, size
             diff=abs(mat(i,j)-conjg(mat(j,i)))
             if (diff>1E-14) then
                 write(*,'(A,2I6,3E12.3)') 'Err hermit ', i,j,diff,
     $ real(mat(i,j)-conjg(mat(j,i))),imag(mat(i,j)-conjg(mat(j,i)))
                 count= count+1
                 if (count>maxcount) then
                    write(*,*) 'max non-hermitian elements encountered'
                    return
                 end if
             end if
         end do
      end do
      return
      end subroutine
#endif


      SUBROUTINE CORE
*
*
*       Density centre & core radius.
*       -----------------------------
*
      INCLUDE 'common6.h'
      REAL*8  RLIST(LMAX),RHO,RHOS
      DATA RHOM/1.0D0/
*
*
*       Set generous cutoff.
      RCORE2 = RSCALE**2
      IF (TIME.GT.0.0D0) RCORE2 = MAX(9.0D0*RC**2,RCORE2)
*
*       Select > N/5 central particles.
*       Initialize neighbour densities of all singles and c.m.
    5 NC = 0
      DO 10 I = IFIRST,NTOT
          RHO(I) = 0.D0
          RI2 = (X(1,I) - RDENS(1))**2 + (X(2,I) - RDENS(2))**2 +
     &                                   (X(3,I) - RDENS(3))**2
          IF (RI2.LT.RCORE2) THEN
              NC = NC + 1
              JLIST(NC) = I
          END IF
   10 CONTINUE
*

      IF (NC.LT.N/5) THEN
          RCORE2 = 1.5*RCORE2
          GO TO 5
      END IF
*
*       Obtain individual densities.
      RHOS = 0.0
      DO 50 L = 1,NC
          I = JLIST(L)
          NNB = LIST(1,I)
*       Skip and set density to zero of there are no neighbours
          IF (NNB.EQ.0) THEN
          RHO(I) = 0.0D0
          ELSE
*       Estimate D6 to limit the candidates (additional factor of 2).
          D6 = 2.0*(6.0/FLOAT(NNB))**0.66*RS(I)**2
          XI = X(1,I)
          YI = X(2,I)
          ZI = X(3,I)
   20     N6 = 0
*
          DO 25 LJ = 1,NNB
              J = LIST(LJ+1,I)
              RIJ2 = (XI - X(1,J))**2 + (YI - X(2,J))**2 +
     &                                  (ZI - X(3,J))**2
              IF (RIJ2.LT.D6) THEN
                  N6 = N6 + 1
                  ILIST(N6) = J
                  RLIST(N6) = RIJ2
              END IF
   25     CONTINUE
*
          IF (N6.LT.6) THEN
*       Make another iteration in rare cases.
              D6 = 1.5*D6
              IF (N6.LT.NNB) GO TO 20
          END IF
*
*       Sort list of square distances.
          DO 40 II = 1,N6
              DO 35 JJ = II+1,N6
                  IF (RLIST(JJ).LT.RLIST(II)) THEN
                      RDUM = RLIST(II)
                      IDUM = ILIST(II)
                      RLIST(II) = RLIST(JJ)
                      ILIST(II) = ILIST(JJ)
                      RLIST(JJ) = RDUM
                      ILIST(JJ) = IDUM
                  END IF
   35         CONTINUE
   40     CONTINUE
*
          I6 = MIN(N6,6)
*       Calculate total mass of five nearest neighbours.
          XMASS = 0.0D0
          DO 45 LJ = 1,I6-1
              XMASS = XMASS + BODY(ILIST(LJ))
   45     CONTINUE
*
          IF (RLIST(I6).GT.0.0D0) THEN
              RINV32 = 1.0D0/(RLIST(I6)*SQRT(RLIST(I6)))
          ELSE
              RINV32 = 0.0D0
          END IF
          RHO(I) = XMASS*RINV32
*       For multi-mass store also five neighbour particle density
          XNDBL(I) = RINV32
*       Assign zero weight if not enough neighbours.
          IF (N6.LT.6) RHO(I) = 0.0D0
          RHOS = MAX(RHOS,RHO(I))
          END IF
   50 CONTINUE
*
*       Determine the density centre.
      DO 60 K = 1,3
          RDENS(K) = 0.0D0
   60 CONTINUE
*
      RHO1 = 0.0D0
      DO 70 L = 1,NC
          I = JLIST(L)
          DO 65 K = 1,3
              RDENS(K) = RDENS(K) + RHO(I)*X(K,I)
   65     CONTINUE
          RHO1 = RHO1 + RHO(I)
   70 CONTINUE
*
*       Set current density centre based on improved determination.
      RHO1 = MAX(RHO1,ZMASS/RSCALE**3)
      DO 75 K = 1,3
          RDENS(K) = RDENS(K)/RHO1
   75 CONTINUE
*
*       Obtain density radius & averaged density.
      RC = 0.0D0
      RHO2 = 0.0D0
      DO 80 L = 1,NC
          I = JLIST(L)
          XID = X(1,I) - RDENS(1)
          YID = X(2,I) - RDENS(2)
          ZID = X(3,I) - RDENS(3)
          RID2 = XID**2 + YID**2 + ZID**2
          RC = RC + RHO(I)**2*RID2
          RHO2 = RHO2 + RHO(I)**2
   80 CONTINUE
*
*       Form core radius and average & maximum density (scaled in OUTPUT).
      IF (RHO2.GT.0.0D0) RC = SQRT(RC/RHO2)
      RHOD = RHO2/RHO1
      RHOD = (3.0/12.566)*RHOD
      RHOM = (3.0/12.566)*RHOS
*       NB! Scaling factor 5 of Casertano & Hut eq. (V.3) replaced by XMASS.
      IF (RC.EQ.0.0D0) THEN
          RC = RSCALE
          NC = N/2
      END IF
*
*       Set square core radius and its inverse for routine REGINT.
      RC2 = RC**2
      RC2IN = 1.0/RC2
*
*       Sum particles & mass inside the core radius and set rms velocity.
      NC1 = 0
      VC = 0.D00
      ZMC = 0.D00
      DO 85 L = 1,NC
          I = JLIST(L)
          XID = X(1,I) - RDENS(1)
          YID = X(2,I) - RDENS(2)
          ZID = X(3,I) - RDENS(3)
          RID2 = XID**2 + YID**2 + ZID**2
          IF (RID2.LT.RC2) THEN
              NC1 = NC1 + 1
              VC = VC + XDOT(1,I)**2 + XDOT(2,I)**2 + XDOT(3,I)**2
              ZMC = ZMC + BODY(I)
          END IF
   85 CONTINUE
*
*       Set core membership & rms velocity.
      NC = MAX(NC1,2)
      VC = SQRT(VC/FLOAT(NC))
*
      RETURN
*
      END


      PROGRAM climatology

c     *************************************************************************
c     * Compile cyclone climatology, extract cyclone fields                   *
c     * Michael Sprenger, Spring 2014                                         *
c     *************************************************************************

      use netcdf

      implicit none

c     ------------------------------------------------------------------------
c     Declaration of parameters
c     ------------------------------------------------------------------------

c     Dimension of ERAi domain
      real    xmin,ymin
      real    dx,dy
      integer nx,ny
      parameter (xmin=-180., ymin=-90.)
      parameter (dx=1.,dy=1.)
      parameter (nx=361,ny=181)

c     Time resolution of the cyclone climatology
      real      deltat
      parameter (deltat=6.)

c     Base directory for cyclone climatology
      character*200 bdir
      parameter
     >(bdir=
     >'/atmosdyn/erainterim/clim/front/4.0K_3ms_500km/cdf.filter/')

c     Numerical epsilon
      real eps
      parameter (eps = 0.0001)

c     ------------------------------------------------------------------------
c     Declaration of variables
c     ------------------------------------------------------------------------

c     Parameters
      integer      first(5)
      integer      final(5)
      character*80 outfile
      character*80 mode
      character*80 datemode,datefile
      character*80 outmode
      character*80 fieldname

c     netCDF variables
      character*100 cdfname
      character*80 varname
      integer      varid
      integer      cdfid
      integer      ierr
      real         misdat
      real         flag(nx,ny),fvel(nx,ny),the(nx,ny)
      real         out(nx,ny)
      real         count(nx,ny)

c     Single variable mode
      real          out_mean(nx,ny)
      real          out_count(nx,ny)
      real          out_sum(nx,ny)
      real          out_var(nx,ny)
      real          n(nx,ny),mean(nx,ny),M2(nx,ny),delta(nx,ny)

c     Auxiliary variables
      integer      i,j
      integer      date(5)
      integer      tmpdate(5)
      character*20 datestr
      integer      year,month,day,hour
      logical      file_exists
      integer      isok
      character*80 field(99),source(99),server(99),modelist(99),typ(99)
      character    ch
      integer      ileft,iright,ifound,imode,nmode,nfield
      character*80 str(10),tmpstr
      real         f_2d(nx,ny)

c     -----------------------------------------------------------------
c     Setup tables for raw data
c     -----------------------------------------------------------------

c     Setup table for data retrieval
      field ( 1)='fronts'
      source( 1)='L'
      server( 1)='free'
      typ   ( 1)='2d'

      field ( 2)='fronts-the'
      source( 2)='L'
      server( 2)='free'
      typ   ( 2)='2d'

      field ( 3)='fronts-fvel'
      source( 3)='L'
      server( 3)='free'
      typ   ( 3)='2d'

      nfield = 3

c     List of valid modes
      modelist( 1) = 'all'
      modelist( 2) = '1';   modelist( 3) = '01'; modelist( 4) = 'jan'
      modelist( 5) = '2';   modelist( 6) = '02'; modelist( 7) = 'feb'
      modelist( 8) = '3';   modelist( 9) = '03'; modelist(10) = 'mar'
      modelist(11) = '4';   modelist(12) = '04'; modelist(13) = 'apr'
      modelist(14) = '5';   modelist(15) = '05'; modelist(16) = 'may'
      modelist(17) = '6';   modelist(18) = '06'; modelist(19) = 'jun'
      modelist(20) = '7';   modelist(21) = '07'; modelist(22) = 'jul'
      modelist(23) = '8';   modelist(24) = '08'; modelist(25) = 'aug'
      modelist(26) = '9';   modelist(27) = '09'; modelist(28) = 'sep'
      modelist(29) = '10';  modelist(30) = 'oct'
      modelist(31) = '11';  modelist(32) = 'nov'
      modelist(33) = '12';  modelist(34) = 'dec'
      modelist(35) = 'djf'; modelist(36) = 'winter'
      modelist(37) = 'mam'; modelist(38) = 'spring'
      modelist(39) = 'jja'; modelist(40) = 'summer'
      modelist(41) = 'son'; modelist(42) = 'autumn'

      nmode = 41

c     ------------------------------------------------------------------------
c     Get parameters
c     ------------------------------------------------------------------------

c     Read parameters
      open(10,file='fort.10')
        read(10,*) datemode,datefile
        read(10,*) first(1),first(2),first(3),first(4)
        read(10,*) final(1),final(2),final(3),final(4)
        read(10,*) mode
        read(10,*) outfile
      close(10)

c     Init climatology arrays
      do i=1,nx
        do j=1,ny
          out(i,j)   = 0.
          count(i,j) = 0.
        enddo
      enddo

c     Init single field, level mode
      do i=1,nx
        do j=1,ny
          out_mean  (i,j)  = 0.
          out_sum   (i,j)  = 0.
          out_count (i,j)  = 0.
          out_var   (i,j)  = 0.
        enddo
      enddo

c     Init arrays for iterative variance calculation
      do i=1,nx
        do j=1,ny
            n(i,j)    = 0.
            mean(i,j) = 0.
            M2(i,j)   = 0.
        enddo
      enddo

c     Decompose the mode descriptor into different sections (. = separator)
      ifound = -1
      ileft  =  1
      iright = 80
      imode  =  0
      do i=1,80
        ch = mode(i:i)
        if ( ch.eq.'.' ) then
            iright     = i-1
            imode      = imode + 1
            str(imode) = mode(ileft:iright)
            ileft      = i + 1
        endif
      enddo
      imode      = imode + 1
      str(imode) = mode(ileft:80)

      print*
      print*,'------------ Parsing ------------------------------------'
      print*
      print*,trim(mode)
      print*
      do i=1,imode
         print*,i,trim(str(i))
      enddo
      print*

c     Get name of variable
      fieldname = 'climatology'
      do i=1,imode
        if ( str(i).eq.'fronts' ) then
           str(i)    = 'nil'
           fieldname = 'fronts'
         elseif ( str(i).eq.'fronts-the' ) then
           str(i)    = 'nil'
           fieldname = 'fronts-the'
         elseif ( str(i).eq.'fronts-fvel' ) then
           str(i)    = 'nil'
           fieldname = 'fronts-fvel'
        endif
      enddo

      print*,'------------ Field --------------------------------------'
      print*
      print*,'field : ',trim(fieldname)
      print*

c     Find the output mode
      outmode='mean'
      if ( fieldname.ne.'climatology' ) then
        do i=1,nmode
          do j=1,imode
             if ( str(j).eq.'dump' ) then
                outmode = 'dump'
                str(j)  = 'nil'
             endif
          enddo
        enddo
      endif

c     Find the mode
      do i=1,nmode
        do j=1,imode
           if ( str(j).eq.modelist(i) ) then
              mode   = modelist(i)
              str(j) = 'nil'
              goto 70
           endif
        enddo
      enddo

      mode = 'all'

 70   continue

      print*,'------------ Mode --------------------------------------'
      print*
      print*,'mode    : ',trim(mode)
      print*,'outmode : ',trim(outmode)
      print*

c     Check that all mode specifiers are handled
      do i=1,imode
        if ( str(i).ne.'nil' ) then
            print*,trim(str(i)),' not recognized... Stop'
            stop
        endif
      enddo

c     ------------------------------------------------------------------------
c     Compile the climatology
c     ------------------------------------------------------------------------

c     Loop over all dates
      if ( datemode.eq.'datestring' ) then
          do i=1,5
             date(i) = first(i)
          enddo
      elseif ( datemode.eq.'datelist' ) then
          open(20,file=datefile)
          read(20,*) datestr
          read(datestr(1:4  ),*) date(1)
          read(datestr(5:6  ),*) date(2)
          read(datestr(7:8  ),*) date(3)
          read(datestr(10:11),*) date(4)
      endif

100   continue

c     Decide whether to include file into climatology
      year  = date(1)
      month = date(2)
      day   = date(3)
      hour  = date(4)

      isok = 0

      if ( mode.eq.'all' ) isok = 1

      if ( mode.eq.'jan' .or. mode.eq.'1' .or. mode.eq.'01' ) then
        if ( month.ne.1 ) goto 120
        isok = 1
      endif
      if ( mode.eq.'feb' .or. mode.eq.'2' .or. mode.eq.'02' ) then
        if ( month.ne.2 ) goto 120
        isok = 1
      endif
      if ( mode.eq.'mar' .or. mode.eq.'3' .or. mode.eq.'03' ) then
        if ( month.ne.3 ) goto 120
        isok = 1
      endif
      if ( mode.eq.'apr' .or. mode.eq.'4' .or. mode.eq.'04' ) then
        if ( month.ne.4 ) goto 120
        isok = 1
      endif
      if ( mode.eq.'may' .or. mode.eq.'5' .or. mode.eq.'05' ) then
        if ( month.ne.5 ) goto 120
        isok = 1
      endif
      if ( mode.eq.'jun' .or. mode.eq.'6' .or. mode.eq.'06' ) then
        if ( month.ne.6 ) goto 120
        isok = 1
      endif
      if ( mode.eq.'jul' .or. mode.eq.'7' .or. mode.eq.'07' ) then
        if ( month.ne.7 ) goto 120
        isok = 1
      endif
      if ( mode.eq.'aug' .or. mode.eq.'8' .or. mode.eq.'08' ) then
        if ( month.ne.8 ) goto 120
        isok = 1
      endif
      if ( mode.eq.'sep' .or. mode.eq.'9' .or. mode.eq.'09' ) then
        if ( month.ne.9 ) goto 120
        isok = 1
      endif
      if ( mode.eq.'oct' .or. mode.eq.'10' ) then
        if ( month.ne.10 ) goto 120
        isok = 1
      endif
      if ( mode.eq.'nov' .or. mode.eq.'11' ) then
        if ( month.ne.11 ) goto 120
        isok = 1
      endif
      if ( mode.eq.'dec' .or. mode.eq.'12' ) then
        if ( month.ne.12 ) goto 120
        isok = 1
      endif

      if ( mode.eq.'djf' .or. mode.eq.'winter' ) then
        if ( month.ne.12 .and. month.ne.1 .and. month.ne.2 ) goto 120
        isok = 1
      endif
      if ( mode.eq.'mam' .or. mode.eq.'spring' ) then
        if ( month.ne.3 .and. month.ne.4 .and. month.ne.5 ) goto 120
        isok = 1
      endif
      if ( mode.eq.'jja' .or. mode.eq.'summer' ) then
        if ( month.ne.6 .and. month.ne.7 .and. month.ne.8 ) goto 120
        isok = 1
      endif
      if ( mode.eq.'son' .or. mode.eq.'autumn' ) then
        if ( month.ne.9 .and. month.ne.10 .and. month.ne.11 ) goto 120
        isok = 1
      endif

      if ( isok.eq.0 ) then
         print*,'Mode unregonized... stop'
         stop
      endif

      write(*,'(i5,i3,i3,i3)') (date(i),i=1,4)

c     Set the filename
      cdfname=bdir
      call datestring(datestr,date(1),-1,-1,-1)
      cdfname=trim(cdfname) // '/' // trim(datestr)
      call datestring(datestr,-1,date(2),-1,-1)
      cdfname=trim(cdfname) // '/' // trim(datestr)
      call datestring(datestr,date(1),date(2),date(3),date(4))
      cdfname=trim(cdfname) // '/L' // trim(datestr) // '.cdf'

c     Check whether file exists
      inquire(file=cdfname, exist=file_exists)
      if ( file_exists.eq..false. ) then
         print*,' WARNING : file is mising ',trim(cdfname)
         goto 120
      endif

c     Load the FLAG from climatology
      ierr = NF90_OPEN(TRIM(cdfname),nf90_nowrite, cdfid)
      IF ( ierr /= nf90_NoErr ) PRINT *,NF90_STRERROR(ierr)

      varname = 'LINE'
      ierr = NF90_INQ_VARID(cdfid,varname,varid)
      IF ( ierr /= nf90_NoErr) PRINT *,NF90_STRERROR(ierr)
      ierr = nf90_get_var(cdfid,varid,flag )
      IF ( ierr /= nf90_NoErr ) PRINT *,NF90_STRERROR(ierr)
      ierr = nf90_get_att(cdfid, varid, "_FillValue", misdat)
      IF ( ierr /= nf90_NoErr ) PRINT *,NF90_STRERROR(ierr)

      if ( fieldname.eq.'fronts-the') then
        varname = 'THE'
        ierr = NF90_INQ_VARID(cdfid,varname,varid)
        IF ( ierr /= nf90_NoErr) PRINT *,NF90_STRERROR(ierr)
        ierr = nf90_get_var(cdfid,varid,the )
        IF ( ierr /= nf90_NoErr ) PRINT *,NF90_STRERROR(ierr)
      endif

      if ( fieldname.eq.'fronts-the') then
        varname = 'FVEL'
        ierr = NF90_INQ_VARID(cdfid,varname,varid)
        IF ( ierr /= nf90_NoErr) PRINT *,NF90_STRERROR(ierr)
        ierr = nf90_get_var(cdfid,varid,fvel )
        IF ( ierr /= nf90_NoErr ) PRINT *,NF90_STRERROR(ierr)
      endif

      ierr = NF90_CLOSE(cdfid)
      IF( ierr /= nf90_NoErr) PRINT *,NF90_STRERROR(ierr)

c     Update climatology arrays
      if ( fieldname.eq.'climatology' ) then
        do i=1,nx
          do j=1,ny

            if ( abs(flag(i,j)-misdat).gt.eps ) then
               if ( flag(i,j).ne.0. ) out(i,j) = out(i,j) + 1.
               count(i,j)   = count(i,j) + 1.
            endif

           enddo
        enddo

c     Update single fields
      else

c       Copy the correct field to f_2d
        do i=1,nx
         do j=1,ny

            if ( fieldname.eq.'fronts' ) then
              if ( abs(flag(i,j)).gt.eps ) then
                  f_2d(i,j) = 1.
              else
                  f_2d(i,j) = 0.
              endif
            endif

            if ( fieldname.eq.'fronts-the' ) then
              if ( abs(flag(i,j)).gt.eps ) then
                  f_2d(i,j) = the(i,j)
              else
                  f_2d(i,j) = misdat
              endif
            endif

            if ( fieldname.eq.'fronts-fvel' ) then
              if ( abs(flag(i,j)).gt.eps ) then
                  f_2d(i,j) = fvel(i,j)
              else
                  f_2d(i,j) = misdat
              endif
            endif

          enddo
        enddo

c       count and sum
        do i=1,nx
          do j=1,ny

            if ( abs(f_2d(i,j)-misdat).gt.eps ) then
               out_sum(i,j)   = out_sum(i,j) + f_2d(i,j)
               out_count(i,j) = out_count(i,j) + 1.
            endif

           enddo
        enddo

c       online calculation of variance
        do i=1,nx
          do j=1,ny

            if ( abs(f_2d(i,j)-misdat).gt.eps ) then
             n(i,j)     = n(i,j) + 1
             delta(i,j) = f_2d(i,j) - mean(i,j)
             mean(i,j)  = mean(i,j) + delta(i,j) / n(i,j)
             M2(i,j)    = M2(i,j) + delta(i,j) * (f_2d(i,j) - mean(i,j))
            endif

           enddo
        enddo

      endif

c     Dump cdf files on request
      if ((outmode.eq.'dump').and.(fieldname.ne.'climatology')) then
         call datestring(datestr,date(1),date(2),date(3),date(4))
         cdfname='D'//trim(datestr)
         varname = trim(fieldname)
         call writecdf2D(cdfname,varname,flag,0.,
     >                dx,dy,xmin,ymin,nx,ny,1,1)
      endif

c     Go to next date
120   continue

      if ( datemode.eq.'datestring' ) then
         call newdate(date,deltat,tmpdate)
         do i=1,5
           date(i) = tmpdate(i)
         enddo
         if ( ( date(1).ne.final(1) ).or.
     >        ( date(2).ne.final(2) ).or.
     >        ( date(3).ne.final(3) ).or.
     >        ( date(4).ne.final(4) ) ) goto 100
      else
          read(20,*,end=130) datestr
          read(datestr(1:4  ),*) date(1)
          read(datestr(5:6  ),*) date(2)
          read(datestr(7:8  ),*) date(3)
          read(datestr(10:11),*) date(4)
          goto 100
130       continue
          close(20)
      endif

c     ------------------------------------------------------------------------
c     Write output to file
c     ------------------------------------------------------------------------

c     Normalize output
      if ( fieldname.eq.'climatology' ) then
        do i=1,nx
          do j=1,ny

           if ( count(i,j).gt.0. ) then
              out(i,j) = out(i,j) / count(i,j)
           else
              out(i,j) = misdat
           endif

          enddo
        enddo

c     Normalize output for single variable
      else

c       Get MEAN
        do i=1,nx
          do j=1,ny

             if ( out_count(i,j).gt.0. ) then
                out_mean(i,j) = out_sum(i,j) / out_count(i,j)
             else
                out_mean(i,j) = misdat
             endif

          enddo
        enddo

c       Set final variance
        do i=1,nx
          do j=1,ny
             if ( abs(n(i,j)-2.).lt.eps ) then
                out_var(i,j) = 0.
             else
                out_var(i,j) = M2(i,j) / ( n(i,j) - 1.)
             endif
          enddo
        enddo

      endif

c     Write climatology field
      if ( fieldname.eq.'climatology' ) then
        cdfname = outfile
        varname = 'FRONT.'//trim(mode)
        call writecdf2D(outfile,varname,out,0.,
     >                  dx,dy,xmin,ymin,nx,ny,1,1)

c     Write output for single level
      else
        cdfname = outfile
        varname = trim(fieldname)//'.MEAN'
        call writecdf2D(outfile,varname,out_mean,0.,
     >                  dx,dy,xmin,ymin,nx,ny,1,1)

        cdfname = outfile
        varname = trim(fieldname)//'.COUNT'
        call writecdf2D(outfile,varname,out_count,0.,
     >                  dx,dy,xmin,ymin,nx,ny,0,1)

        cdfname = outfile
        varname = trim(fieldname)//'.SUM'
        call writecdf2D(outfile,varname,out_sum,0.,
     >                  dx,dy,xmin,ymin,nx,ny,0,1)

        cdfname = outfile
        varname = trim(fieldname)//'.VAR'
        call writecdf2D(outfile,varname,out_var,0.,
     >                  dx,dy,xmin,ymin,nx,ny,0,1)

      endif

      end

c     --------------------------------------------------------------------
c     Subroutines to write the netcdf output file
c     --------------------------------------------------------------------

      subroutine writecdf2D(cdfname,
     >                      varname,arr,time,
     >                      dx,dy,xmin,ymin,nx,ny,
     >                      crefile,crevar)

c     Create and write to the netcdf file <cdfname>. The variable
c     with name <varname> and with time <time> is written. The data
c     are in the two-dimensional array <arr>. The list <dx,dy,xmin,
c     ymin,nx,ny> specifies the output grid. The flags <crefile> and
c     <crevar> determine whether the file and/or the variable should
c     be created

      IMPLICIT NONE

c     Declaration of input parameters
      character*80 cdfname,varname
      integer nx,ny
      real arr(nx,ny)
      real dx,dy,xmin,ymin
      real time
      integer crefile,crevar

c     Further variables
      real varmin(4),varmax(4),stag(4)
      integer ierr,cdfid,ndim,vardim(4)
      character*80 cstname
      real mdv
      integer datar(14),stdate(5)
      integer i

C     Definitions
      varmin(1)=xmin
      varmin(2)=ymin
      varmin(3)=1050.
      varmax(1)=xmin+real(nx-1)*dx
      varmax(2)=ymin+real(ny-1)*dy
      varmax(3)=1050.
      cstname=trim(cdfname)//'_cst'
      ndim=4
      vardim(1)=nx
      vardim(2)=ny
      vardim(3)=1
      stag(1)=0.
      stag(2)=0.
      stag(3)=0.
      mdv=-999.98999

C     Create the file
      if (crefile.eq.0) then
         call cdfwopn(cdfname,cdfid,ierr)
         if (ierr.ne.0) goto 906
      else if (crefile.eq.1) then
         call crecdf(cdfname,cdfid,
     >        varmin,varmax,ndim,cstname,ierr)
         if (ierr.ne.0) goto 903

C        Write the constants file
         datar(1)=vardim(1)
         datar(2)=vardim(2)
         datar(3)=int(1000.*varmax(2))
         datar(4)=int(1000.*varmin(1))
         datar(5)=int(1000.*varmin(2))
         datar(6)=int(1000.*varmax(1))
         datar(7)=int(1000.*dx)
         datar(8)=int(1000.*dy)
         datar(9)=1
         datar(10)=1
         datar(11)=0            ! data version
         datar(12)=0            ! cstfile version
         datar(13)=0            ! longitude of pole
         datar(14)=90000        ! latitude of pole
         do i=1,5
            stdate(i)=0
         enddo
c         call wricst(cstname,datar,0.,0.,0.,0.,stdate)
      endif

c     Write the data to the netcdf file, and close the file
      if (crevar.eq.1) then
         call putdef(cdfid,varname,ndim,mdv,
     >        vardim,varmin,varmax,stag,ierr)
         if (ierr.ne.0) goto 904
      endif
      call putdat(cdfid,varname,time,0,arr,ierr)
      if (ierr.ne.0) goto 905
      call clscdf(cdfid,ierr)

      return

c     Error handling
 903  print*,'*** Problem to create netcdf file ***'
      stop
 904  print*,'*** Problem to write definition ***'
      stop
 905  print*,'*** Problem to write data ***'
      stop
 906  print*,'*** Problem to open netcdf file ***'
      stop

      END

c     ---------------------------------------------------------------------------
c     Concatenate a date string
c     ---------------------------------------------------------------------------

      subroutine datestring(datestr,yyyy,mm,dd,hh)

c     Declaration of subroutine parameters
      integer yyyy,mm,dd,hh
      character*20 datestr

c     Auxiliary parameters
      integer f1,f2,i0
      integer yy,ce

      i0=ichar('0')
      datestr=''

      yy=mod(yyyy,100)
      ce=int(yyyy/100)

      if ((ce.ne.19).and.(ce.ne.20).and.(yyyy.gt.0)) then
         print*,'Invalid year... Stop'
         stop
      endif

      if (yy.ge.0) then
         f1=yy/10
         f2=mod(yy,10)
         if (ce.eq.19) then
            datestr=trim(datestr)//'19'//char(f1+i0)//char(f2+i0)
         else if (ce.eq.20) then
            datestr=trim(datestr)//'20'//char(f1+i0)//char(f2+i0)
         endif
      endif
      if (mm.gt.0) then
         f1=mm/10
         f2=mod(mm,10)
         datestr=trim(datestr)//char(f1+i0)//char(f2+i0)
      endif

      if (dd.gt.0) then
         f1=dd/10
         f2=mod(dd,10)
         datestr=trim(datestr)//char(f1+i0)//char(f2+i0)
      endif

      if (hh.ge.0) then
         f1=hh/10
         f2=mod(hh,10)
         datestr=trim(datestr)//'_'//char(f1+i0)//char(f2+i0)
      endif

      return
      end

c     ---------------------------------------------------------------------------
c     Calculates the new date when diff (in hours) is added to date1.
c     ---------------------------------------------------------------------------

      subroutine newdate(date1,diff,date2)
C
C     date1     int     input   array contains a date in the form
C                               year,month,day,hour,step
C     diff      real    input   timestep in hours to go from date1
C     date2     int     output  array contains new date in the same form

      integer   date1(5),date2(5)
      integer   idays(12)       ! array containing the days of the monthes
      real      diff
      logical   yearchange

      data idays/31,28,31,30,31,30,31,31,30,31,30,31/

      yearchange=.false.

      if ((mod(date1(1),4).eq.0).and.(date1(2).le.2)) idays(2)=29

      date2(1)=date1(1)
      date2(2)=date1(2)
      date2(3)=date1(3)
      date2(4)=date1(4)
      date2(5)=0
      date2(4)=date1(4)+int(diff)+date1(5)

      if (date2(4).ge.24) then
        date2(3)=date2(3)+int(date2(4)/24)
        date2(4)=date2(4)-int(date2(4)/24)*24
      endif
      if (date2(4).lt.0) then
        if (mod(date2(4),24).eq.0) then
          date2(3)=date2(3)-int(abs(date2(4))/24)
          date2(4)=date2(4)+int(abs(date2(4))/24)*24
        else
          date2(3)=date2(3)-(1+int(abs(date2(4))/24))
          date2(4)=date2(4)+(1+int(abs(date2(4))/24))*24
        endif
      endif

  100 if (date2(3).gt.idays(date2(2))) then
        if ((date2(2).eq.2).and.(mod(date2(1),4).eq.0)) idays(2)=29
        date2(3)=date2(3)-idays(date2(2))
        if (idays(2).eq.29) idays(2)=28
        date2(2)=date2(2)+1
        if (date2(2).gt.12) then
*         date2(1)=date2(1)+int(date2(2)/12)
*         date2(2)=date2(2)-int(date2(2)/12)*12
          date2(1)=date2(1)+1
          date2(2)=date2(2)-12
        endif
        if (date2(2).lt.1) then
          date2(1)=date2(1)-(1+int(abs(date2(2)/12)))
          date2(2)=date2(2)+(1+int(abs(date2(2)/12)))*12
        endif
        goto 100
      endif
  200 if (date2(3).lt.1) then
        date2(2)=date2(2)-1
        if (date2(2).gt.12) then
          date2(1)=date2(1)+int(date2(2)/12)
          date2(2)=date2(2)-int(date2(2)/12)*12
        endif
        if (date2(2).lt.1) then
          date2(1)=date2(1)-(1+int(abs(date2(2)/12)))
          date2(2)=date2(2)+(1+int(abs(date2(2)/12)))*12
        endif
        if ((date2(2).eq.2).and.(mod(date2(1),4).eq.0)) idays(2)=29
        date2(3)=date2(3)+idays(date2(2))
        if (idays(2).eq.29) idays(2)=28
        goto 200
      endif

      if (date2(2).gt.12) then
        date2(1)=date2(1)+int(date2(2)/12)
        date2(2)=date2(2)-int(date2(2)/12)*12
      endif
      if (date2(2).lt.1) then
        date2(1)=date2(1)-(1+int(abs(date2(2)/12)))
        date2(2)=date2(2)+(1+int(abs(date2(2)/12)))*12
      endif

      if (date2(1).lt.1000) then
      if (date2(1).ge.100) date2(1)=date2(1)-100
      endif

      return
      end


      REAL*8 FUNCTION RPMAX(M1,M2,VSTAR,DV,PERI)
*
*
*       Maximum periastron distance for GR capture.
*       -------------------------------------------
*       Quinlan & Shapiro, Ap.J. 343, 725, 1989.
*
*
      IMPLICIT REAL*8 (A-H,M,O-Z)
      DATA FAC /2.6790/
*
*
*       Note M1, M2 and DV are in N-body units.
      MB = M1 + M2
      MFAC = (M1*M2)**(2.0/7.0)*MB**(3.0/7.0)
      CLIGHT = 3.0D+05/VSTAR
      VFAC = CLIGHT**(10.0/7.0)*DV**(4.0/7.0)
      RPMAX = FAC*MFAC/VFAC
*
*       Include diagnostics for testing (suppressed).
*     WRITE (6,5)  M1, M2, DV, RPMAX, PERI
*   5 FORMAT (' RPMAX    M1 M2 DV RPX PERI ',1P,5E10.2)
*     CALL FLUSH(6)
      RETURN
      END


      DOUBLE PRECISION FUNCTION DCPLTE(EM)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1998-10-29 DCPLTE Krogh  Moved external statement up for mangle.
c>> 1996-03-30 DCPLTE Krogh   Changed MAX to MAXT
C>> 1994-10-27 DCPLTE Snyder  Correct missing type declarations
C>> 1994-10-20 DCPLTE Krogh  Changes to use M77CON
C>> 1994-05-16 DCPLTE Snyder  Make SP and DP codes alike using CHGTYP
C>> 1989-06-16 DCPLTE Snyder  Remove implied DO from DATA stmts for CFT
C>> 1985-08-02 DCPLTE Lawson  Initial code.
c--D replaces "?": ?CPLTE, ?ERM1
C
C     Complete elliptic integral E(EM). Method given by
C     W.J.CODY, Math. of Comp.,Vol.19, (1965), pp. 105-111.
C     Data are taken from Cody's table in reverse order.
C     We are using N = 5 or 9 for single precision and
C     N = 10 for double precision.
C
C     C.L.LAWSON & STELLA CHAN,JPL,1983 JUNE.
C
C     ----------------------------------------------------
C
C     POLY DEGREE     NEGATIVE LOG BASE 10 OF MAX ABS
C                     ERROR OF APPROXIMATION
C
C         N           FOR K           FOR E
C         -           -----           -----
C         5            9.50            9.44
C         9           15.87           15.84
C        10           17.45           17.42
C
C     ----------------------------------------------------
C
      EXTERNAL D1MACH
      DOUBLE PRECISION C(10,3), D(10,3), D1MACH
      DOUBLE PRECISION EM, EMP, FAC, HALF, ONE, S3, S4, U, ZERO
      INTEGER J, M, MAXT
C
      SAVE M, MAXT, FAC
C
      DATA ZERO,ONE,HALF / 0.D0, 1.D0 ,.5D0 /
C
      DATA M / 0 /
c
      DATA C / 7.65296060328D-03, 3.06623474572D-02,
     *         3.17611455247D-02, 5.75669984841D-02,
     *         4.43152874726D-01, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,

     *         3.25192015506390418D-04, 4.30253777479311659D-03,
     *         1.17858410087339355D-02, 1.18419259955012494D-02,
     *         9.03552773754088184D-03, 1.17167669446577228D-02,
     *         2.18361314054868967D-02, 5.68052233293082895D-02,
     *         4.43147180583368137D-01, 0.0D0,

     *         1.4946621757181326771D-04,2.4685033304607227339D-03,
     *         8.6384421736040744302D-03,1.0770635039866455473D-02,
     *         7.8204040609595541727D-03,7.5950934225594322802D-03,
     *         1.1569595745295402175D-02,2.1831811676130481568D-02,
     *         5.6805194567559156648D-02,4.4314718056088952648D-01/
C
      DATA D / 2.12479182845D-03, 2.18360211693D-02,
     *         5.42605244487D-02, 9.35649078307D-02,
     *         2.49999202736D-01, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,

     *         7.20316963457154599D-05, 1.86453791840633632D-03,
     *         1.00879584943751004D-02, 2.26603098916041221D-02,
     *         3.28110691727210618D-02, 4.26725101265917523D-02,
     *         5.85927071842652739D-02, 9.37499951163670673D-02,
     *         2.49999999997461423D-01, 0.0D0,

     *         3.1859195655501571800D-05,9.8983328462253847867D-04,
     *         6.4321465864383017666D-03,1.6804023346363384981D-02,
     *         2.6145014700313878932D-02,3.3478943665761626232D-02,
     *         4.2717890547383095644D-02,5.8593661255531491732D-02,
     *         9.3749999721203140658D-02,2.4999999999990177208D-01/
C
      IF (M .EQ. 0) THEN
        IF (D1MACH(3) .LT. 6.31d-17) THEN
C         -LOG10(6.31D-17) = 17.2
          M = 3
          MAXT = 10
        ELSE IF (D1MACH(3) .LT. 6.31D-9) THEN
C         -LOG10(6.31D-9) = 8.2
          M = 2
          MAXT = 9
        ELSE
          M = 1
          MAXT = 5
        END IF
        FAC = ONE + 2 * D1MACH(3)
      END IF
      IF (EM .GT. ONE) THEN
        CALL DERM1('DCPLTE',1,0,'UNDEFINED FOR EM .GT. ONE',
     *             'EM',EM,'.')
        U = ZERO
      ELSE IF (EM .LT. ZERO) THEN
        CALL DERM1('DCPLTE',2,0,'UNDEFINED FOR EM .LT. ZERO',
     *             'EM',EM,'.')
        U = ZERO
      ELSE
        EMP = HALF + (HALF- EM)
        IF (EMP .EQ. ZERO) THEN
          U = ONE
          GO TO 10
        END IF
        S3 = EMP * C(1,M)
        S4 = EMP * D(1,M)
        DO 100 J = 2, MAXT
          S3 = (S3 + C(J,M)) * EMP
          S4 = (S4 + D(J,M)) * EMP
  100   CONTINUE
        U = ONE + S3 + LOG(ONE/EMP) * S4
      END IF
C
  10  DCPLTE = U * FAC
      RETURN
C
      END


      subroutine jac1 (neq, t, y, ml, mu, pd, nrowpd)
      integer neq, ml, mu, nrowpd
      double precision t, y, pd
      dimension y(*), pd(nrowpd,*)
      dimension neq(*)
      pd(1,1) = 0.0d0
      pd(1,2) = 1.0d0
      pd(2,1) = -40.0d0*y(1)*y(2) - 1.0d0
      pd(2,2) = 20.0d0*(1.0d0 - y(1)*y(1))
      return
      end


   !        Generated by TAPENADE     (INRIA, Tropics team)
   !  Tapenade 3.10 (r5363) -  9 Sep 2014 09:53
   !
   !  Differentiation of getelementprops in reverse (adjoint) mode (with options noISIZE i4 dr8 r8):
   !   gradient     of useful results: area points normal
   !   with respect to varying inputs: points
   SUBROUTINE GETELEMENTPROPS_B(points, pointsb, npts, area, areab, normal&
   & , normalb)
   USE CONSTANTS
   IMPLICIT NONE
   ! Subroutine Variables
   INTEGER(kind=inttype), INTENT(IN) :: npts
   REAL(kind=realtype), DIMENSION(3, npts), INTENT(IN) :: points
   REAL(kind=realtype), DIMENSION(3, npts) :: pointsb
   REAL(kind=realtype), DIMENSION(3) :: normal
   REAL(kind=realtype), DIMENSION(3) :: normalb
   REAL(kind=realtype) :: area
   REAL(kind=realtype) :: areab
   ! Local variables
   INTEGER(kind=inttype) :: i
   REAL(kind=realtype), DIMENSION(3, npts) :: radialvec
   REAL(kind=realtype), DIMENSION(3, npts) :: radialvecb
   REAL(kind=realtype), DIMENSION(3) :: center, cross
   REAL(kind=realtype), DIMENSION(3) :: centerb, crossb
   REAL(kind=realtype) :: crossnorm
   REAL(kind=realtype) :: crossnormb
   INTRINSIC SQRT
   REAL(kind=realtype), DIMENSION(3) :: tmp
   INTEGER :: branch
   REAL(kind=realtype) :: temp0
   REAL(kind=realtype) :: tempb0
   REAL(kind=realtype) :: tmpb(3)
   REAL(kind=realtype) :: tempb
   REAL(kind=realtype) :: temp
   ! Compute the element center:
   center(:) = zero
   DO i=1,npts
   center(:) = center(:) + points(:, i)
   END DO
   center = center/npts
   ! compute the vector from the center to each point defining the element
   DO i=1,npts
   radialvec(:, i) = points(:, i) - center
   END DO
   ! Now loop around element doing cross products to get directional area
   CALL PUSHREAL8ARRAY(normal, realtype*3/8)
   normal = zero
   DO i=1,npts
   IF (i .LT. npts) THEN
   CALL PUSHREAL8ARRAY(cross, realtype*3/8)
   CALL CROSS_PRODUCT_3D(radialvec(:, i), radialvec(:, i+1), cross&
   &                       )
   CALL PUSHCONTROL1B(0)
   ELSE
   CALL PUSHREAL8ARRAY(cross, realtype*3/8)
   CALL CROSS_PRODUCT_3D(radialvec(:, i), radialvec(:, 1), cross)
   CALL PUSHCONTROL1B(1)
   END IF
   CALL PUSHREAL8ARRAY(crossnorm, realtype/8)
   crossnorm = SQRT(cross(1)**2 + cross(2)**2 + cross(3)**2 + 1e-15)
   normal = normal + cross/crossnorm
   END DO
   temp = normal(1)**2 + normal(2)**2 + normal(3)**2
   temp0 = SQRT(temp)
   tmpb = normalb
   normalb = tmpb/temp0
   IF (temp .EQ. 0.0_8) THEN
   tempb0 = 0.0
   ELSE
   tempb0 = SUM(-(normal*tmpb/temp0))/(temp0**2*2.0)
   END IF
   normalb(1) = normalb(1) + 2*normal(1)*tempb0
   normalb(2) = normalb(2) + 2*normal(2)*tempb0
   normalb(3) = normalb(3) + 2*normal(3)*tempb0
   crossb = 0.0_8
   radialvecb = 0.0_8
   DO i=npts,1,-1
   crossb = crossb + normalb/crossnorm
   crossnormb = half*areab + SUM(-(cross*normalb/crossnorm))/crossnorm
   CALL POPREAL8ARRAY(crossnorm, realtype/8)
   IF (cross(1)**2 + cross(2)**2 + cross(3)**2 + 1e-15 .EQ. 0.0_8) THEN
   tempb = 0.0
   ELSE
   tempb = crossnormb/(2.0*SQRT(cross(1)**2+cross(2)**2+cross(3)**2+&
   &       1e-15))
   END IF
   crossb(1) = crossb(1) + 2*cross(1)*tempb
   crossb(2) = crossb(2) + 2*cross(2)*tempb
   crossb(3) = crossb(3) + 2*cross(3)*tempb
   CALL POPCONTROL1B(branch)
   IF (branch .EQ. 0) THEN
   CALL POPREAL8ARRAY(cross, realtype*3/8)
   CALL CROSS_PRODUCT_3D_B(radialvec(:, i), radialvecb(:, i), &
   &                       radialvec(:, i+1), radialvecb(:, i+1), cross, &
   &                       crossb)
   ELSE
   CALL POPREAL8ARRAY(cross, realtype*3/8)
   CALL CROSS_PRODUCT_3D_B(radialvec(:, i), radialvecb(:, i), &
   &                       radialvec(:, 1), radialvecb(:, 1), cross, crossb&
   &                      )
   END IF
   END DO
   CALL POPREAL8ARRAY(normal, realtype*3/8)
   centerb = 0.0_8
   DO i=npts,1,-1
   pointsb(:, i) = pointsb(:, i) + radialvecb(:, i)
   centerb = centerb - radialvecb(:, i)
   radialvecb(:, i) = 0.0_8
   END DO
   centerb = centerb/npts
   DO i=npts,1,-1
   pointsb(:, i) = pointsb(:, i) + centerb
   END DO
   END SUBROUTINE GETELEMENTPROPS_B


C######################################################################|
      module calculate_avalanche_growthrate
C----------------------------------------------------------------------|
C     This module is used to calculate the avalanche runaway growth
C     rate.
C
C     Functions:
C       - avalanche_growthrate
C       - avalanche_growthrate_classic
C       - p_star
C
C     Function arguments:
C       - Z:    atomic number of each ion species
C       - Z0:   net charge of plasma for each ion species
C       - nj:   density of each ion species (m**-3)
C       - nSpe: number of ion species
C       - T:    electron temperature (eV)
C       - Epar: parallel electric field (V/m)
C       - eps:  local r/R
C       - B:    magnetic field (T)
C
C----------------------------------------------------------------------|
      use double
      use physical_constants, only :
     >  pi
      use Coulomb_logarithms, only :
     >  ln_Lambda_0, ln_Lambda_c
      use collision_frequencies, only :
     >  nu_ee, nuBar_D, nuBar_S
      use electric_fields, only :
     >  E_c, E_ceff_over_E_c, E_D

      implicit none

      private

      public ::
     >  avalanche_growthrate_classic,
     >  avalanche_growthrate,
     >  p_star

        ! ----- Parameters --------------------------------------------|
      integer, parameter ::
     >  iter_max    = 100               ! maximum number of iterations

      real(kind=dp), parameter ::
     >  iter_acc    = 1.0e-8_dp         ! target accuracy of iterations

      contains

C======================================================================|
      real(kind=dp) function avalanche_growthrate_classic(Z, Z0, nj,
     >  nSpecies, T, Epar, eps) result (Gamma_av)
C----------------------------------------------------------------------|
C     The flux of secondary electrons to relativistic momenta is
C     calculated according to Eq. (18) in M.N. Rosenbluth and S.V.
C     Putvinski, Nucl. Fusion 37, 1355 (1997).
C
C     Input:
C       Z   : atomic number of each ion species
C       Z0  : net charge of plasma for each ion species
C       nj  : density of each ion species (m**-3)
C       nSpe: number of ion species
C           Z, Z0 and nj must be vectors of length nSpecies
C       T   : temperature (eV)
C       Epar: parallel electric field (V/m)
C       eps : local r/R
C
C     Output:
C       Gamm: flux of secondary runaway electrons (1/s)
C
C----------------------------------------------------------------------|
        ! ----- Function arguments ------------------------------------|
      integer, intent(in) ::
     >  nSpecies, Z(nSpecies), Z0(nSpecies)

      real(kind=dp), intent(in) ::
     >  Epar, eps, nj(nSpecies), T

        ! ----- Local variables ---------------------------------------|
      integer ::
     >  i

      real(kind=dp) ::
     >  arg, Ec, fac, gam, ne, Zeff

C----------------------------------------------------------------------|
C     Construct required quantities
C----------------------------------------------------------------------|
        ! ----- Free electron density ---------------------------------|
      ne = sum(Z0(:)*nj(:))

        ! ----- Critical electric field -------------------------------|
      Ec = E_c(ne, T)

        ! ----- Pre-factor: physical constants ------------------------|
      fac = 5.866792055096e+02_dp

        ! ----- Effective charge --------------------------------------|
      Zeff = sum(Z0(:)**2*nj(:))/ne

        ! ----- Geometric factor --------------------------------------|
      gam = 1._dp/(1 + 1.46_dp*sqrt(eps) + 1.72_dp*eps)

        ! ----- Argument of sqrt --------------------------------------|
      arg = 1 - Ec/Epar + 4*pi*(Zeff+1)**2
     >      / 3._dp/gam/(Zeff+5)/(Epar**2/Ec**2 + 4._dp/gam**2-1)

C----------------------------------------------------------------------|
C     Calculate growth rate
C----------------------------------------------------------------------|
      if (arg .gt. 0._dp) then
        Gamma_av = fac * sqrt(pi*gam/3._dp/(Zeff+5))*(Epar-Ec)
     >      / ln_Lambda_c(ne, T) / sqrt(arg)
      else
        Gamma_av = 0._dp
      endif

      return
      end function avalanche_growthrate_classic
C======================================================================|

C======================================================================|
      real(kind=dp) function avalanche_growthrate(Z, Z0, nj, nSpecies,
     >  T, Epar, B) result (Gamma_av)
C----------------------------------------------------------------------|
C     The flux of secondary electrons to relativistic momenta is
C     calculated according to Eq. (14) in L. Hesslow et al., Nucl.
C     Fusion 59, 084004 (2019).
C
C     Input:
C       Z   : atomic number of each ion species
C       Z0  : net charge of plasma for each ion species
C       nj  : density of each ion species (m**-3)
C       nSpe: number of ion species
C           Z, Z0 and nj must be vectors of length nSpecies
C       T   : temperature (eV)
C       Epar: parallel electric field (V/m)
C       B   : magnetic field (T)
C
C     Output:
C       Gamm: flux of secondary runaway electrons (1/s)
C
C----------------------------------------------------------------------|
        ! ----- Function arguments ------------------------------------|
      integer, intent(in) ::
     >  nSpecies, Z(nSpecies), Z0(nSpecies)

      real(kind=dp), intent(in) ::
     >  B, Epar, nj(nSpecies), T

        ! ----- Local variables ---------------------------------------|
      integer ::
     >  i

      real(kind=dp) ::
     >  ne, ne_tot, pstar

C----------------------------------------------------------------------|
C     Construct required quantities
C----------------------------------------------------------------------|
        ! ----- Free electron density ---------------------------------|
      ne = sum(Z0(:)*nj(:))

        ! ----- Total electron density --------------------------------|
      ne_tot = sum(Z( :)*nj(:))

        ! ----- Effective critical momentum for runaway ---------------|
      pstar = p_star(Z, Z0, nj, nSpecies, T, Epar, B)

C----------------------------------------------------------------------|
C     Calculate growth rate
C----------------------------------------------------------------------|
      Gamma_av  = 5.8667920978923496e+02_dp
     >  * ne_tot/ne * E_c(ne, T) / ln_Lambda_c(ne, T)
     >  * (Epar/E_c(ne, T) - E_ceff_over_E_c(Z, Z0, nj, nSpecies, T,B))
     >  / sqrt(4 + nuBar_D(Z, Z0, nj, nSpecies, T, pstar)
     >           * nuBar_S(Z, Z0, nj, nSpecies, T, pstar))

      return
      end function avalanche_growthrate
C======================================================================|

C======================================================================|
      real(kind=dp) function p_star(Z, Z0, nj, nSpecies,
     >  T, Epar, B)
C----------------------------------------------------------------------|
C     Calculates the critical normalised momentum for electron runaway
C     according to L. Hesslow et al., Nucl. Fusion 59, 084004 (2019),
C     just below Eq. (12).
C
C     Input:
C       Z   : atomic number of each ion species
C       Z0  : net charge of plasma for each ion species
C       nj  : density of each ion species (m**-3)
C       nSpe: number of ion species
C           Z, Z0 and nj must be vectors of length nSpecies
C       T   : temperature (eV)
C       E   : parallel electric field (V/m)
C
C     Output:
C       psta: critical momentum for electron runaway, normalised to me/c
C
C----------------------------------------------------------------------|
        ! ----- Function arguments ------------------------------------|
      integer, intent(in) ::
     >  nSpecies, Z(nSpecies), Z0(nSpecies)

      real(kind=dp), intent(in) ::
     >  B, nj(nSpecies), T, Epar

        ! ----- Local variables ---------------------------------------|
      integer ::
     >  i

      real(kind=dp) ::
     >  EE_c, ne, p_old

C----------------------------------------------------------------------|
C     Construct required quantities
C----------------------------------------------------------------------|
        ! ----- Free electron density ---------------------------------|
      ne = sum(Z0(:)*nj(:))

        ! ----- Normalised electric field -----------------------------|
      EE_c = max(Epar/E_c(ne, T),
     >           E_ceff_over_E_c(Z, Z0, nj, nSpecies, T, B))

C----------------------------------------------------------------------|
C     Obtain critical momentum iteratively
C----------------------------------------------------------------------|
      p_star = 1._dp

      do i=1,iter_max
        p_old = p_star
        p_star = sqrt(1._dp/EE_c*sqrt(
     >        nuBar_S(Z(:), Z0(:), nj(:), nSpecies, T, p_star)
     >      * nuBar_D(Z(:), Z0(:), nj(:), nSpecies, T, p_star)))

        if (abs(p_star-p_old) .le. iter_acc)
     >      exit
      enddo

      return
      end function p_star
C======================================================================|

      end module calculate_avalanche_growthrate
C######################################################################|


C    %W% %G%
      subroutine pieqix (brnch,gk1,bk1,gk2,bk2,g12,b12,g21,b21)
C ***
C *** This subroutine computes the 2-port Y-matrix from the PF
C *** branch addressed as BRNCH. The pi-equivalents are extracted
C *** from the Y-matrix.
C ***
C *** Note the unusual method in which integer equivalents are
C *** obtained from BRNCH: (RK1,K1), (RK2,K2), (RLIST,LIST), and
C *** (RLTYPE,LTYPE)
C *** PIEQIX IS CALLED BY BRNCHY AND GETYEQ. IT IS IDENTICAL TO
C *** SUBROUTNE PIEQIV EXCEPT FOR ONE COMMON BLOCK
C ***
      include 'tspinc/params.inc'
      include 'tspinc/namec.inc'
      include 'tspinc/pointr.inc'
      dimension brnch(18)
      complex y(2,2), cx
      equivalence (rk1,k1), (rk2,k2), (rltype,ltype), (rlist,list)
      rltype = brnch(1)
      rk1 = brnch(2)
      rk2 = brnch(12)
      rlist = brnch(17)
      go to (1700,1700,1000,1700,1000,1000,1700,1000)ltype
C ***
C *** Compute transfer impedance
C ***
 1000 r = brnch(5)
      x = brnch(6)
      z = r * *2 + x * *2
      go to (1700,1900,1200,1900,1400,1500,1900,1300) ltype
C ***
C *** " L " branch
C ***
 1200 y(1,2) = -cmplx (r/z, -x/z)
      y(2,1) = y(1,2)
      y(1,1) = cmplx (brnch(7),brnch(8)) - y(1,2)
      y(2,2) = y(1,1)
      go to 1800
C ***
C *** " E " branch
C ***
 1300 y(1,2)= -cmplx (r/z, -x/z)
      y(2,1) = y(1,2)
      y(1,1) = cmplx(brnch(7),brnch(8)) - y(1,2)
      y(2,2) = cmplx(brnch(9),brnch(10)) - y(2,1)
      go to 1800
C ***
C *** " T " branch
C ***
 1400 kb1 = ixnamn(k1)
      kb2 = ixnamn(k2)
      tk = brnch(9) / basekv(kb1)
      tm = brnch(10) / basekv(kb2)
      tkm = 1.0 / (tk*tm)
      y(1,1) = cmplx(0.5*tkm*brnch(7),-0.5*tkm*abs(brnch(8)))
      y(2,2) = y(1,1)
      y(1,2) = -cmplx(r/(z*tk*tm),-x/(z*tk*tm))
      y(2,1) = y(1,2)
      y(1,1) = y(1,1) + cmplx (r/(z*tk*tk),-x/(z*tk*tk))
      y(2,2) = y(2,2) + cmplx (r/(z*tm*tm), -x/(z*tm*tm))
      go to 1800
C ***
C *** " TP " branch
C ***
 1500 kb1 = ixnamn(k1)
      kb2 = ixnamn(k2)
      tk = brnch(9)
      if (list .eq. 0) tm = brnch(10) / basekv(kb1)
      if (list .eq. 1) tm = brnch(10) / basekv(kb2)
      if (tm .eq. 0.0) tm = 1.0
      angle = 0.0174532925 * tk
      y(1,2) = cmplx(0.5*brnch(7),-0.5*abs(brnch(8)))
      y(1,1) = y(1,2) + cmplx(r/z,-x/z)
      y(2,2) = y(1,2) + cmplx(r/z,-x/z) / cmplx(tm**2,0.0)
      y(1,2) = -cmplx(cos(angle),sin(angle)) *
     1   cmplx(r/(z*tm),-x/(z*tm))
      y(2,1) = -cmplx(cos(angle),-sin(angle)) *
     1   cmplx(r/(z*tm),-x/(z*tm))
      if (list .ne. 0) then
         cx = y(2,2)
         y(2,2) = y(1,1)
         y(1,1) = cx
      endif
      go to 1800
C ***
C *** " L "  EQUIVALENT BRANCH
C ***
 1700 gk1 = brnch(4) + brnch(6)
      bk1 = brnch(5) + brnch(7)
      g12 = -brnch(6)
      b12 = -brnch(7)
      g21 = -brnch(8)
      b21 = -brnch(9)
      gk2 = brnch(10) + brnch(8)
      bk2 = brnch(11) + brnch(9)
      go to 1900
 1800 continue
      gk1 = real (y(1,1)+y(1,2))
      bk1 = aimag (y(1,1)+y(1,2))
      gk2 = real (y(2,2)+y(2,1))
      bk2 = aimag (y(2,2)+y(2,1))
      g12 = -real (y(1,2))
      b12 = -aimag (y(1,2))
      g21 = -real (y(2,1))
      b21 = -aimag (y(2,1))
 1900 return
      end


      COMPLEX FUNCTION CEXP1(A,B)
      COMPLEX CMPLX
      DATA HAPI,PI,TWOPI/1.570796327,3.141592654,6.283185308/
C     C=AMOD(B+SIGN(PI,B),TWOPI)-SIGN(PI,B)
C     BA=ABS(C)
C     T=HAPI-BA
C     IF(T.LT.0) BA=PI-BA
C     B2=BA*BA
C     CEXP1=CMPLX(SIGN(1.+B2*(-.49670+B2*.03705),T),
C    $            SIGN(BA*(1.+B2*(-.16605+B2*.00761)),C))/
C    $            (1.+A*(1.+A*(.5+A*(.166666+A*.04166666))))
      CEXP1=CMPLX(COS(B),SIN(B))/EXP(A)
      RETURN
      END


program test_split
use iso_fortran_env,only:int8,int16,int32,int64,real32,real64,real128
use mod_testing,only:assert,initialize_tests,report_tests
use mod_functional,only:arange,split

implicit none

logical,dimension(:),allocatable :: tests
logical :: test_failed
integer :: n,norder,ntests
integer,parameter :: stdout = 6

n = 1
ntests = 16
call initialize_tests(tests,ntests)

tests(n) = assert(all(split(arange(1_int8,10_int8),1) == arange(1,5)),&
                  'split(x,1), int8')
n = n + 1

tests(n) = assert(all(split(arange(1_int8,10_int8),2) == arange(6,10)),&
                  'split(x,2), int8')
n = n + 1

tests(n) = assert(all(split(arange(1_int16,10_int16),1) == arange(1,5)),&
                  'split(x,1), int16')
n = n + 1

tests(n) = assert(all(split(arange(1_int16,10_int16),2) == arange(6,10)),&
                  'split(x,2), int16')
n = n + 1

tests(n) = assert(all(split(arange(1_int32,10_int32),1) == arange(1,5)),&
                  'split(x,1), int32')
n = n + 1

tests(n) = assert(all(split(arange(1_int32,10_int32),2) == arange(6,10)),&
                  'split(x,2), int32')
n = n + 1

tests(n) = assert(all(split(arange(1_int64,10_int64),1) == arange(1,5)),&
                  'split(x,1), int64')
n = n + 1

tests(n) = assert(all(split(arange(1_int64,10_int64),2) == arange(6,10)),&
                  'split(x,2), int64')
n = n + 1

tests(n) = assert(all(split(arange(1._real32,10._real32),1) == arange(1,5)),&
                  'split(x,1), real32')
n = n + 1

tests(n) = assert(all(split(arange(1._real32,10._real32),2) == arange(6,10)),&
                  'split(x,2), real32')
n = n + 1

tests(n) = assert(all(split(arange(1._real64,10._real64),1) == arange(1,5)),&
                  'split(x,1), real64')
n = n + 1

tests(n) = assert(all(split(arange(1._real64,10._real64),2) == arange(6,10)),&
                  'split(x,2), real64')
n = n + 1

tests(n) = assert(all(split(arange(1._real128,10._real128),1) == arange(1,5)),&
                  'split(x,1), real128')
n = n + 1

tests(n) = assert(all(split(arange(1._real128,10._real128),2) == arange(6,10)),&
                  'split(x,2), real128')
n = n + 1

tests(n) = assert(all(split([1],1) == arange(1,0)),'split([1],1) returns an empty array')
n = n + 1

tests(n) = assert(all(split([1],2) == [1]),'split([1],2) returns [1]')
n = n + 1

test_failed = .false.
call report_tests(tests,test_failed)
if(test_failed)stop 1

endprogram test_split


program unum_to_general_test
  use ISO_FORTRAN_ENV, only : REAL64
  use unum_to_float_mod
  use unum_to_general_conversion_mod
  use unum_env_mod
  use unum_t_mod
  use ubound_t_mod
  use general_interval_t_mod
  use real_to_unum_mod
  use display_env_mod, only : Display_unum => Display_env
  use display_unum_as_real_mod

  implicit none

  type (unum_t)   :: unum_exact1
  type (unum_t)   :: unum_exact2
  type (unum_t)   :: unum_inexact1
  type (unum_t)   :: unum_inexact2
  type (unum_t)   :: ubitmask_local
  type (ubound_t) :: ubound_closed_closed
  type (ubound_t) :: ubound_closed_open
  type (ubound_t) :: ubound_open_closed
  type (ubound_t) :: ubound_open_open

  real (REAL64) :: real_temp1, real_temp2

  type (general_interval_t) :: g_interval

  call Set_unum_env (4, 5)

  real_temp1 = 0.1
  real_temp2 = 2.1
  ubitmask_local = Get_ubitmask ()

  unum_exact1 = Exact(X2u (real_temp1))
  unum_exact2 = Exact(X2u (real_temp2))
  print *, 'unum_exact1 is'
  call Display_unum (unum_exact1)
  print *, 'unum_exact1 back to real is: '
  call Display_unum_as_real (unum_exact1)
  print *, 'unum_exact1 should be: ', real_temp1
  print *, 'unum_exact2 is'
  call Display_unum (unum_exact2)
  print *, 'unum_exact2 back to real is: '
  call Display_unum_as_real (unum_exact2)
  print *, 'unum_exact2 should be: ', real_temp2
  unum_inexact1%u = unum_exact1%u + ubitmask_local%u
  unum_inexact2%u = unum_exact2%u + ubitmask_local%u
  print *, 'unum_inexact1 is'
  call Display_unum (unum_inexact1)
  print *, 'unum_inexact2 is'
  call Display_unum (unum_inexact2)
  call Display_unum_as_real (unum_inexact2)

  ubound_closed_closed%ub = [unum_exact1, unum_exact2]
  ubound_closed_open%ub   = [unum_exact1, unum_inexact2]
  ubound_open_closed%ub   = [unum_inexact1, unum_exact2]
  ubound_open_open%ub     = [unum_inexact1, unum_inexact2]

  g_interval = U2g (ubound_open_open)

  print *, g_interval%endpoints
  print *, g_interval%are_closed

end program unum_to_general_test