MODULE NEURALNET_MOD
! Hompack real precision module for approximately 64-bit arithmetic on all
! known machines.
USE REAL_PRECISION
! Default to public.
PUBLIC

! Derived data type for constructing a single layer of a neural network.
TYPE LAYER
   INTEGER :: NNODES
   REAL(KIND=R8), ALLOCATABLE :: INPUTS(:), OUTPUTS(:)
   LOGICAL :: BIAS
   PROCEDURE(ACTIVATION), NOPASS, POINTER :: F
CONTAINS
   PROCEDURE, PASS :: FWPROP => FWPROP
   PROCEDURE, PASS :: BWPROP => BWPROP
END TYPE LAYER

! Derived data type for a neural network object.
TYPE NEURALNET
   INTEGER :: NLAYERS
   INTEGER, ALLOCATABLE :: NODESPERLAYER(:)
   REAL(KIND=R8), ALLOCATABLE :: WEIGHTS(:)
   REAL(KIND=R8), ALLOCATABLE :: BIAS(:)
   TYPE(LAYER), ALLOCATABLE :: LAYERS(:)
CONTAINS
   PROCEDURE, PASS :: ADD => ADDLAYER
   PROCEDURE, PASS :: EVALUATE => EVALUATE
   PROCEDURE, PASS :: BACKPROP => BACKPROP
   PROCEDURE, PASS :: TRAIN => TRAIN
END TYPE NEURALNET

! Interface for layer activation functions.
INTERFACE
   FUNCTION ACTIVATION(INPUT, FW)
      USE REAL_PRECISION
      IMPORT LAYER
      REAL(KIND=R8), INTENT(IN) :: INPUT
      LOGICAL, INTENT(IN) :: FW
      REAL(KIND=R8) :: ACTIVATION
   END FUNCTION ACTIVATION
END INTERFACE

! Interface for LAYER constructor.
INTERFACE LAYER
   MODULE PROCEDURE NEWLAYER
END INTERFACE

! Interface for NEURALNET constructor.
INTERFACE NEURALNET
   MODULE PROCEDURE NEWNEURALNET
END INTERFACE

CONTAINS

! --- Procedures for the LAYER class --- !

FUNCTION NEWLAYER(SIZE, IERR, BIAS, ACTIVATION)
! Constructor for LAYER objects.
   IMPLICIT NONE
   ! Parameter list.
   INTEGER, INTENT(IN) :: SIZE
   INTEGER, INTENT(OUT) :: IERR
   TYPE(LAYER) :: NEWLAYER
   LOGICAL, OPTIONAL, INTENT(IN) :: BIAS
   OPTIONAL :: ACTIVATION
   ! Interface for ACTIVATION function parameter.
   INTERFACE
      FUNCTION ACTIVATION(INPUT, FW)
         USE REAL_PRECISION
         REAL(KIND=R8), INTENT(IN) :: INPUT
         LOGICAL, INTENT(IN) :: FW
         REAL(KIND=R8) :: ACTIVATION
      END FUNCTION ACTIVATION
   END INTERFACE
   ! Check whether SIZE is a legal value.
   IF (SIZE < 1) THEN
      IERR = -1; RETURN; END IF
   ! Initialize the values of the new layer object.
   NEWLAYER%NNODES = SIZE
   NEWLAYER%BIAS = .FALSE.
   NEWLAYER%F => LINEAR
   ! Allocate the INPUTS and OUTPUTS arrays.
   ALLOCATE(NEWLAYER%INPUTS(SIZE), NEWLAYER%OUTPUTS(SIZE), STAT=IERR)
   IF (IERR .NE. 0) RETURN
   ! Set the activation function.
   IF (PRESENT(BIAS)) NEWLAYER%BIAS = BIAS
   IF (PRESENT(ACTIVATION)) NEWLAYER%F => ACTIVATION
   RETURN
END FUNCTION NEWLAYER

SUBROUTINE FWPROP(THIS)
! Propogate function evaluation forward through the activation function.
   IMPLICIT NONE
   ! Calling object.
   CLASS(LAYER), INTENT(INOUT) :: THIS
   ! Loop index.
   INTEGER :: I
   ! Propogate all values.
   DO I = 1, THIS%NNODES
      THIS%OUTPUTS(I) = THIS%F(THIS%INPUTS(I),.TRUE.)
   END DO
   RETURN
END SUBROUTINE FWPROP

SUBROUTINE BWPROP(THIS)
! Propogate gradient evaluation backward through the activation function.
   IMPLICIT NONE
   ! Calling object.
   CLASS(LAYER), INTENT(INOUT) :: THIS
   ! Loop index.
   INTEGER :: I
   ! Propogate all values.
   DO I = 1, THIS%NNODES
      THIS%INPUTS(I) = THIS%F(THIS%OUTPUTS(I),.FALSE.)
   END DO
   RETURN
END SUBROUTINE BWPROP

! --- Procedures for the NEURALNET class --- !

FUNCTION NEWNEURALNET()
! Constructor for NEURALNETWORK objects.
   IMPLICIT NONE
   TYPE(NEURALNET) :: NEWNEURALNET
   NEWNEURALNET%NLAYERS = 0
   RETURN
END FUNCTION NEWNEURALNET

SUBROUTINE ADDLAYER(THIS, NEWLAYER, IERR)
! Add a layer NEWLAYER to the calling NEURALNETWORK object.
   IMPLICIT NONE
   CLASS(NEURALNET), INTENT(INOUT) :: THIS
   CLASS(LAYER), INTENT(IN) :: NEWLAYER
   INTEGER, INTENT(OUT) :: IERR
   ! Local variables.
   INTEGER :: ITMP
   TYPE(LAYER), ALLOCATABLE :: TMP_LAYERS(:)
   INTEGER, ALLOCATABLE :: TMP_NPL(:)
   ! Check for a legal NEWLAYER.
   IF ( .NOT. ALLOCATED(NEWLAYER%INPUTS) .OR. &
        .NOT. ALLOCATED(NEWLAYER%OUTPUTS) ) THEN
      IERR = -2; RETURN; END IF
   ! Save temporary values. We do not save the weights because it is assumed
   ! that the NN has not been trained yet.
   ! If NODESPERLAYER is nonempty, save the current contents.
   IF (ALLOCATED(THIS%NODESPERLAYER)) THEN
      ALLOCATE(TMP_NPL(THIS%NLAYERS), STAT=IERR)
      IF (IERR .NE. 0) RETURN
      TMP_NPL(:) = THIS%NODESPERLAYER(:)
      DEALLOCATE(THIS%NODESPERLAYER, STAT=IERR)
      IF (IERR .NE. 0) RETURN
   END IF
   ! If LAYERS is nonempty, save the current contents.
   IF (ALLOCATED(THIS%LAYERS)) THEN
      ALLOCATE(TMP_LAYERS(THIS%NLAYERS), STAT=IERR)
      IF (IERR .NE. 0) RETURN
      TMP_LAYERS(:) = THIS%LAYERS(:)
      DEALLOCATE(THIS%LAYERS, STAT=IERR)
      IF (IERR .NE. 0) RETURN
   END IF
   ! Increment the number of layers.
   THIS%NLAYERS = THIS%NLAYERS + 1
   ! Reallocate the NODESPERLAYER counter and the LAYERS array.
   ALLOCATE(THIS%NODESPERLAYER(THIS%NLAYERS), THIS%LAYERS(THIS%NLAYERS), &
      & STAT=IERR)
   IF (IERR .NE. 0) RETURN
   ! If the NODESPERLAYER and LAYERS arrays were nonempty, recover the tmp
   ! values.
   IF (ALLOCATED(TMP_NPL)) THEN
      THIS%NODESPERLAYER(1:THIS%NLAYERS-1) = TMP_NPL(:)
   END IF
   IF (ALLOCATED(TMP_LAYERS)) THEN
      THIS%LAYERS(1:THIS%NLAYERS-1) = TMP_LAYERS(:)
   END IF
   ! Add the new values.
   THIS%NODESPERLAYER(THIS%NLAYERS) = NEWLAYER%NNODES
   THIS%LAYERS(THIS%NLAYERS) = NEWLAYER
   ! If this is the input layer, there is nothing else to do.
   IF (THIS%NLAYERS .EQ. 1) RETURN
   ! Otherwise, reallocate the flattened WEIGHTS array in accordance with
   ! the new network dimensions.
   IF (ALLOCATED(THIS%WEIGHTS)) DEALLOCATE(THIS%WEIGHTS, STAT=IERR)
   IF (IERR .NE. 0) RETURN
   ITMP = DOT_PRODUCT(THIS%NODESPERLAYER(2:THIS%NLAYERS), &
      & THIS%NODESPERLAYER(1:THIS%NLAYERS-1))
   ALLOCATE(THIS%WEIGHTS(ITMP), STAT=IERR)
   IF (IERR .NE. 0) RETURN
   ! Check whethr NEWLAYER is biased.
   IF (NEWLAYER%BIAS) THEN
      ! Compute the size of the BIAS array.
      ITMP = NEWLAYER%NNODES
      IF (ALLOCATED(THIS%BIAS)) THEN
         ITMP = ITMP + SIZE(THIS%BIAS,1)
         DEALLOCATE(THIS%BIAS, STAT=IERR)
         IF (IERR .NE. 0) RETURN
      END IF
      ALLOCATE(THIS%BIAS(ITMP), STAT=IERR)
      IF (IERR .NE. 0) RETURN
   END IF
   RETURN
END SUBROUTINE ADDLAYER

FUNCTION EVALUATE(THIS, X, IERR)
! Evaluate a trained NEURALNETWORK object at a REAL vector X(:).
   IMPLICIT NONE
   ! Parameter list.
   CLASS(NEURALNET), INTENT(INOUT) :: THIS
   REAL(KIND=R8), INTENT(IN) :: X(:)
   INTEGER, INTENT(OUT) :: IERR
   REAL(KIND=R8) :: EVALUATE
   ! Local variables.
   INTEGER :: OFFSETB, OFFSETW ! Book keeping variables.
   INTEGER :: I ! Loop indexing variables.
   ! External procedures.
   EXTERNAL :: DGEMV ! Blas subroutine for matrix vector multiplication.
   ! Check for illegal inputs.
   IF (SIZE(X, 1) .NE. THIS%NODESPERLAYER(1)) THEN
      IERR = -2; RETURN; END IF
   IF (THIS%NLAYERS < 2) THEN
      IERR = -1; RETURN; END IF
   IF (THIS%NODESPERLAYER(THIS%NLAYERS) .NE. 1) THEN
      IERR = -1; RETURN; END IF
   ! Initialize the first layer and offsets.
   THIS%LAYERS(1)%INPUTS(:) = X(:)
   CALL THIS%LAYERS(1)%FWPROP()
   OFFSETW = 1; OFFSETB = 1
   ! Propogate values through the hidden layers.
   DO I = 2, THIS%NLAYERS
      ! If this layer is biased, introduce the biases.
      IF (THIS%LAYERS(I)%BIAS) THEN
         THIS%LAYERS(I)%INPUTS(:) = &
            & THIS%BIAS(OFFSETB:OFFSETB+THIS%NODESPERLAYER(I)-1)
         OFFSETB = OFFSETB + THIS%NODESPERLAYER(I)
      ! Otherwise, initialize all the inputs to zero values.
      ELSE
         THIS%LAYERS(I)%INPUTS(:) = 0.0_R8
      END IF
      ! Propogate input from the previous layer through a linear transform.
      CALL DGEMV('N', THIS%NODESPERLAYER(I), THIS%NODESPERLAYER(I-1),   &
               & 1.0_R8, THIS%WEIGHTS(OFFSETW:), THIS%NODESPERLAYER(I), &
               & THIS%LAYERS(I-1)%OUTPUTS, 1, 1.0_R8,                   &
               & THIS%LAYERS(I)%INPUTS, 1)
      ! Propogate through the activation function.
      CALL THIS%LAYERS(I)%FWPROP()
      ! Track the current offset.
      OFFSETW = OFFSETW + (THIS%NODESPERLAYER(I-1) * THIS%NODESPERLAYER(I))
   END DO
   ! Copy outputs from the final layer.
   EVALUATE = THIS%LAYERS(THIS%NLAYERS)%OUTPUTS(1)
   RETURN
END FUNCTION EVALUATE

SUBROUTINE BACKPROP(THIS, WEIGHTS, BIAS, DATA, LOSS, IERR)
! Evaluate the gradient of the LOSS function with respect to WEIGHTS by
! backprojecting through the layers of the calling NEURALNETWORK object.
   IMPLICIT NONE
   ! Parameter list.
   CLASS(NEURALNET), INTENT(INOUT) :: THIS
   REAL(KIND=R8), INTENT(INOUT) :: WEIGHTS(:)
   REAL(KIND=R8), INTENT(INOUT) :: BIAS(:)
   REAL(KIND=R8), INTENT(IN) :: DATA(:,:)
   INTEGER, INTENT(OUT) :: IERR
   ! Interface for LOSS.
   INTERFACE
      FUNCTION LOSS(PRED, ACTUAL)
         USE REAL_PRECISION
         IMPORT LAYER
         REAL(KIND=R8), INTENT(IN) :: PRED, ACTUAL
         REAL(KIND=R8) :: LOSS
      END FUNCTION LOSS
   END INTERFACE
   ! Local variables.
   INTEGER :: D, N, M ! Problem dimensions.
   INTEGER :: I, J ! Loop indexing variables.
   INTEGER :: STARTW, FINISHW ! Book keeping variables for weights.
   INTEGER :: STARTB, FINISHB ! Book keeping variables for biases.
   REAL(KIND=R8) :: RTMP ! Temporary variable for storing loss.
   ! External procedures.
   EXTERNAL :: DGEMV ! Blas subroutine for matrix vector multiplication.
   EXTERNAL :: DGER ! Blas subroutine for applying a rank 1 update.
   ! Get sizes.
   D = SIZE(DATA, 1) - 1
   N = SIZE(WEIGHTS, 1)
   M = SIZE(BIAS, 1)
   ! Check for illegal sizes.
   IF (THIS%NLAYERS < 2) THEN
      IERR = -1; RETURN; END IF
   IF (THIS%NODESPERLAYER(THIS%NLAYERS) .NE. 1) THEN
      IERR = -1; RETURN; END IF
   IF (N .NE. SIZE(THIS%WEIGHTS, 1)) THEN
      IERR = -2; RETURN; END IF
   IF (ALLOCATED(THIS%BIAS) .AND. M .NE. SIZE(THIS%BIAS, 1)) THEN
      IERR = -3; RETURN; END IF
   IF (D .NE. THIS%NODESPERLAYER(1)) THEN
      IERR = -4; RETURN; END IF
   ! Set the weights and biases and initialize the gradients.
   THIS%WEIGHTS(:) = WEIGHTS(:)
   IF (ALLOCATED(THIS%BIAS)) THEN
      THIS%BIAS(:) = BIAS(:)
      BIAS(:) = 0.0_R8
   END IF
   WEIGHTS(:) = 0.0_R8
   ! Loop over all points in the data set.
   DO I = 1, SIZE(DATA, 2)
      ! There is just one node in the output layer. The derivative of the
      ! loss function with respect to its output is the derivative of the
      ! loss function with respect to the output of the current model.
      RTMP = LOSS(THIS%EVALUATE(DATA(1:D,I),IERR), DATA(D+1,I)) &
         & / SIZE(DATA,2)
      IF (IERR .NE. 0) RETURN
      THIS%LAYERS(THIS%NLAYERS)%OUTPUTS(1) = RTMP
      ! Backproject through the final activation function.
      CALL THIS%LAYERS(THIS%NLAYERS)%BWPROP()
      ! Track the memory offsets.
      FINISHW = N
      STARTW = N - THIS%NODESPERLAYER(THIS%NLAYERS-1) + 1
      FINISHB = M
      ! Evaluate the partial derivative with respect to the weights using
      ! the output from the previous layer.
      WEIGHTS(STARTW:FINISHW) = WEIGHTS(STARTW:FINISHW) + &
         & THIS%LAYERS(THIS%NLAYERS-1)%OUTPUTS(:) * &
         & THIS%LAYERS(THIS%NLAYERS)%INPUTS(1)
      IF (THIS%LAYERS(THIS%NLAYERS)%BIAS) THEN
         BIAS(M) = BIAS(M) + THIS%LAYERS(THIS%NLAYERS)%INPUTS(1)
         FINISHB = FINISHB - 1
      END IF
      ! Backproject the gradient through the rest of the layers.
      DO J = THIS%NLAYERS-1, 2, -1
         ! Compute the gradient of the loss function with respect to the
         ! input to the current layer.
         THIS%LAYERS(J)%OUTPUTS(:) = 0.0_R8
         CALL DGEMV('T', THIS%NODESPERLAYER(J+1), THIS%NODESPERLAYER(J), &
               & 1.0_R8, THIS%WEIGHTS(STARTW:FINISHW),                   &
               & THIS%NODESPERLAYER(J+1), THIS%LAYERS(J+1)%INPUTS, 1,    &
               & 1.0_R8, THIS%LAYERS(J)%OUTPUTS, 1)
         CALL THIS%LAYERS(J)%BWPROP()
         ! Update the current offsets.
         FINISHW = STARTW - 1
         STARTW = STARTW - THIS%NODESPERLAYER(J) * THIS%NODESPERLAYER(J-1)
         ! Apply the rank 1 update to the current weights gradient.
         CALL DGER(THIS%NODESPERLAYER(J), THIS%NODESPERLAYER(J-1), 1.0_R8, &
               & THIS%LAYERS(J)%INPUTS(:), 1, THIS%LAYERS(J-1)%OUTPUTS, 1, &
               & WEIGHTS(STARTW:FINISHW), THIS%NODESPERLAYER(J))
         ! Check if this layer is biased.
         IF (THIS%LAYERS(J)%BIAS) THEN
            ! Get the new starting offset.
            STARTB = FINISHB - THIS%NODESPERLAYER(J) + 1
            ! Add directly to the biases.
            BIAS(STARTB:FINISHB) = BIAS(STARTB:FINISHB) &
               & + THIS%LAYERS(J)%INPUTS(:)
            ! Update the new ending offset.
            FINISHB = STARTB - 1
         END IF
      END DO
   END DO
END SUBROUTINE BACKPROP

SUBROUTINE TRAIN(THIS, DATA, IERR, LOSS, REG, LAMBDA)
! Train a neural network object using backpropogation + SGD.
   USE OPT_MOD
   IMPLICIT NONE
   ! Parameter list.
   CLASS(NEURALNET), INTENT(INOUT) :: THIS
   REAL(KIND=R8), INTENT(IN) :: DATA(:,:)
   INTEGER, INTENT(OUT) :: IERR
   REAL(KIND=R8), OPTIONAL, INTENT(IN) :: LAMBDA
   OPTIONAL :: LOSS, REG
   ! Interfaces for optionals LOSS and REG.
   INTERFACE
      FUNCTION LOSS(PRED, ACTUAL)
         USE REAL_PRECISION
         REAL(KIND=R8), INTENT(IN) :: PRED, ACTUAL
         REAL(KIND=R8) :: LOSS
      END FUNCTION LOSS
      FUNCTION REG(WEIGHT)
         USE REAL_PRECISION
         REAL(KIND=R8), INTENT(IN) :: WEIGHT
         REAL(KIND=R8) :: REG
      END FUNCTION REG
   END INTERFACE
   ! Local variables.
   INTEGER :: NUMWEIGHTS, NUMBIAS
   REAL(KIND=R8), ALLOCATABLE :: CURR_WEIGHTS(:)
   REAL(KIND=R8), ALLOCATABLE :: CURR_BIAS(:)
   REAL(KIND=R8), ALLOCATABLE :: CURR_X(:)
   REAL(KIND=R8) :: LAMBDAL
   PROCEDURE(LOSS), POINTER :: LOSSL => MSE
   INTEGER :: I
   ! External procedures.
   REAL(KIND=R8), EXTERNAL :: DNRM2 ! Blas subroutine for Euclidean distance.
   ! Get problem dimensions.
   NUMWEIGHTS = SIZE(THIS%WEIGHTS,1)
   IF (ALLOCATED(THIS%BIAS)) THEN
      NUMBIAS = SIZE(THIS%BIAS,1)
      ALLOCATE(CURR_BIAS(NUMBIAS), STAT=IERR)
      IF (IERR .NE. 0) RETURN
   ELSE
      NUMBIAS = 0
   END IF
   ! Allocate temporary variables for tracking progress.
   ALLOCATE(CURR_WEIGHTS(NUMWEIGHTS), CURR_X(NUMWEIGHTS+NUMBIAS), STAT=IERR)
   IF (IERR .NE. 0) RETURN
   ! Set optional variables and procedures, if present.
   LAMBDAL = 0.5_R8
   IF (PRESENT(LAMBDA)) LAMBDAL = LAMBDA
   IF (PRESENT(LOSS)) LOSSL => LOSS
   ! Randomly initialize weights in [-1, 1].
   CALL RANDOM_NUMBER(CURR_X(:))
   CURR_X(:) = 2.0_R8 * (CURR_X(:) - 0.5_R8)
   CURR_X(NUMWEIGHTS+1:NUMWEIGHTS+NUMBIAS) = 0.0_R8
   ! Solve with stochastic gradient descent.
   CALL SGD(NUMWEIGHTS+NUMBIAS, BACKPROP_GRAD, CURR_X, &
          & IBUDGET=10000, TAU=1.0_R8)
   RETURN
CONTAINS
   SUBROUTINE BACKPROP_GRAD(D, X, G)
   ! Internal subroutine for passing the gradient to SGD.
      INTEGER, INTENT(IN) :: D
      REAL(KIND=R8), INTENT(IN) :: X(D)
      REAL(KIND=R8), INTENT(OUT) :: G(D)
      CURR_WEIGHTS(:) = X(1:NUMWEIGHTS)
      IF (ALLOCATED(CURR_BIAS)) THEN
         CURR_BIAS(:) = X(NUMWEIGHTS+1:NUMWEIGHTS+NUMBIAS); END IF
      CALL THIS%BACKPROP(CURR_WEIGHTS, CURR_BIAS, DATA, LOSSL, IERR)
      IF (IERR .NE. 0) THEN; G(:) = 0.0_R8; RETURN; END IF
      G(1:NUMWEIGHTS) = CURR_WEIGHTS(:)
      ! Add regularization terms.
      IF (PRESENT(REG)) THEN
         DO I = 1, NUMWEIGHTS
            G(I) = G(I) + LAMBDAL * REG(X(I))
         END DO
      END IF
      ! Update the biases if present.
      IF (ALLOCATED(CURR_BIAS)) THEN
         G(NUMWEIGHTS+1:NUMWEIGHTS+NUMBIAS) = CURR_BIAS(:); END IF
      !G(:) = G(:) / DNRM2(D, G, 1) ! uncomment for gradient normalization
   END SUBROUTINE BACKPROP_GRAD
END SUBROUTINE TRAIN

! --- Activation functions --- !

FUNCTION LINEAR(INPUT, FW)
! Definition of the linear activation function.
   IMPLICIT NONE
   ! Parameter list.
   REAL(KIND=R8), INTENT(IN) :: INPUT
   LOGICAL, INTENT(IN) :: FW
   REAL(KIND=R8) :: LINEAR
   ! The parameter FW is not used for the linear function.
   LINEAR = INPUT
   RETURN
END FUNCTION LINEAR

FUNCTION RELU(INPUT, FW)
! Definition of the Rectified Linear Unit activation function.
   IMPLICIT NONE
   ! Parameter list.
   REAL(KIND=R8), INTENT(IN) :: INPUT
   LOGICAL, INTENT(IN) :: FW
   REAL(KIND=R8) :: RELU
   ! The parameter FW is not used for the RELU function.
   RELU = INPUT
   RELU = MAX(0.0_R8, RELU)
   RETURN
END FUNCTION RELU

FUNCTION SIGMOID(INPUT, FW)
! Definition of the sigmoidal activation function.
   IMPLICIT NONE
   ! Parameter list.
   REAL(KIND=R8), INTENT(IN) :: INPUT
   LOGICAL, INTENT(IN) :: FW
   REAL(KIND=R8) :: SIGMOID
   ! First compute the sigmoid function.
   SIGMOID = 1.0_R8 / (1.0_R8 + EXP(-INPUT))
   ! If backpropogating, then compute the derivative * INPUT.
   IF (.NOT. FW) THEN
      SIGMOID = INPUT * (SIGMOID * (1.0_R8 - SIGMOID))
   END IF
   RETURN
END FUNCTION SIGMOID

FUNCTION HYPERTAN(INPUT, FW)
! Definition of the hyperpolic tangent activation function.
! Note that TANH is already a Fortran intrinsic.
   IMPLICIT NONE
   ! Parameter list.
   REAL(KIND=R8), INTENT(IN) :: INPUT
   LOGICAL, INTENT(IN) :: FW
   REAL(KIND=R8) :: HYPERTAN
   ! First compute the sigmoid function.
   HYPERTAN = TANH(INPUT)
   ! If backpropogating, then compute the derivative * INPUT.
   IF (.NOT. FW) THEN
      HYPERTAN = INPUT * (1.0_R8 - (HYPERTAN ** 2.0_R8))
   END IF
   RETURN
END FUNCTION HYPERTAN

! --- Loss functions --- !

FUNCTION MSE(PRED, ACTUAL)
! Definition of the squared error (L2) loss function.
   IMPLICIT NONE
   ! Parameter list.
   REAL(KIND=R8), INTENT(IN) :: PRED, ACTUAL
   REAL(KIND=R8) :: MSE
   ! Return the gradient of the loss function.
   MSE = 2.0_R8 * (PRED - ACTUAL)
   RETURN
END FUNCTION MSE

FUNCTION MAE(PRED, ACTUAL)
! Definition of the absolute error (L1) loss function.
   IMPLICIT NONE
   ! Parameter list.
   REAL(KIND=R8), INTENT(IN) :: PRED, ACTUAL
   REAL(KIND=R8) :: MAE
   MAE = SIGN(1.0_R8, PRED - ACTUAL)
END FUNCTION

! --- Regularization functions --- !

FUNCTION L2(WEIGHT)
! Definition of the squared error (L2) regularization function.
   IMPLICIT NONE
   ! Parameter list.
   REAL(KIND=R8), INTENT(IN) :: WEIGHT
   REAL(KIND=R8) :: L2
   ! Return the gradient of the regularization function: SUM(W**2)/2.
   L2 = WEIGHT
   RETURN
END FUNCTION L2

FUNCTION L1(WEIGHT)
! Definition of the absolute error (L1) regularization function.
   IMPLICIT NONE
   ! Parameter list.
   REAL(KIND=R8), INTENT(IN) :: WEIGHT
   REAL(KIND=R8) :: L1
   ! Return the gradient of the regularization function: SUM(W**2)/2.
   L1 = SIGN(1.0_R8, WEIGHT)
   RETURN
END FUNCTION L1

END MODULE NEURALNET_MOD


program PoissonMG2DTest
! A 2D Poisson solver on a uniform mesh using multigrid with red/black smoothing.  The RHS
! vector is assumed to be scaled such that the discretized Laplace operator has a 1 on the
! diagonal element.
! May be compiled on a unix machine with:  g95 PoissonMG2DTest.f90 -o PoissonMG2DTest
! -------------------------------------- USER INPUT --------------------------------------
! XBC=1 for hom. Dirichlet (0:NX), =2 for periodic (-1:NX), =3 for hom. Neumann (-1:NX+1).
! Same for YBC. NX, NY must be powers of two with NX>=NY. N1,N2,N3 set how much smoothing
integer :: NX=1024, NY=1024, XBC=3, YBC=3, N1=2, N2=2, N3=2 ! is applied at various steps.
! ----------------------------------- END OF USER INPUT ----------------------------------
integer :: xo, yo, nlev                                                 ! global variables
type :: arrays; sequence; real*8, pointer :: d(:,:); end type arrays
type grid; sequence; integer :: nx, ny, xm, ym; end type grid
type(arrays):: d(0:16), v(0:16);  type(grid) :: g(0:16); real*16 :: z, h

print *, 'BCs: ',XBC,',',YBC,'. Smoothing: ',N1,',',N2,',',N3,'.  Grids:'
call PoissonMG2DInit
z=0; do j=3,g(0)%ym-2; do i=3,g(0)%xm-2          ! The RHS vector b is stored in the
    call random_number(h); d(0)%d(i,j)=h; z=z+h  ! initial value of -d [see (3.8a)], here
end do; end do                                   ! taken as a zero-mean random number.
d(0)%d(3:g(0)%xm-2,3:g(0)%ym-2)=d(0)%d(3:g(0)%xm-2,3:g(0)%ym-2)-z/(g(0)%xm-4)/(g(0)%ym-4)
call PoissonMG2D
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
contains
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine PoissonMG2DInit
! This initialization routine allocates several global arrays to avoid the repeated
! memory allocation/deallocation otherwise caused by recursion.  Note that d and v are
! defined as arrays of arrays, which are of different size at each level l.
select case(XBC); case(1); xo=1; case(2); xo=2; case(3); xo=2; end select
select case(YBC); case(1); yo=1; case(2); yo=2; case(3); yo=2; end select
nlev=int(log10(real(NY))/log10(2.0))-1; call random_seed; sum = 0.0
do l=0,nlev
   g(l)%nx = NX/(2**l); g(l)%ny = NY/(2**l);  ! The g data structure contains
   g(l)%xm=g(l)%nx+XBC; g(l)%ym=g(l)%ny+YBC;  ! information about the grids.
   allocate(v(l)%d(g(l)%xm,g(l)%ym)); allocate(d(l)%d(g(l)%xm,g(l)%ym));
   v(l)%d=0.0; d(l)%d=0.0;  print *,l,g(l)%nx,g(l)%ny   ! d=defect, v=correction.
end do
end subroutine PoissonMG2DInit
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine PoissonMG2D
integer :: ta(8)
e=MaxDefect(0); print *,'Iter=0, max defect=',e
do k=1,N1; call Smooth(0); end do ! APPLY SMOOTHING BEFORE STARTING MULTIGRID (N1 times)
! call date_and_time(values=ta); t = ta(5)*3600 + ta(6)*60 + ta(7) + 0.001*ta(8)
main: do iter=1,10                ! PERFORM UP TO 10 MULTIGRID CYCLES.
   o=e; call Multigrid(0); e = MaxDefect(0);
   print *,'Iter=',iter,', max defect=',e,'factor=',o/e
   if (e<1E-13) then; print *,'Converged'; exit main; end if
end do main
! call date_and_time(values=ta); t = ta(5)*3600 + ta(6)*60 + ta(7) + 0.001*ta(8) - t
! print *,'-> Total time: ',t,' sec; Time/iteration: ',t/iter,' sec'
do l=0,nlev; deallocate(v(l)%d); deallocate(d(l)%d); end do
end subroutine PoissonMG2D
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
recursive subroutine Multigrid(l)
! The main recursive function of the multigrid algorithm. It calls the smoothing function,
! it performs the restriction and prolongation, and calls itself on the coarser grid.
do k=1,N2; call Smooth(l); end do    !  APPLY SMOOTHING STEPS BEFORE COARSENING (N2 times)
! Now COMPUTE THE DEFECT and RESTRICT it to the coarser grid in a single step.
! TRICK #1 we calculate the defect ONLY on the red points here, as the defect on the
! neighboring black points is zero coming out of the previous call to Smooth.
! TRICK #2: We skip a factor of /2 during the restriction here. We also skip factors of
! *4 during the smoothing and /2 during the prolongation, so the skipped factors cancel.
do jc=2,g(l+1)%ym-1; j=2*(jc-yo)+yo; do ic=2,g(l+1)%xm-1;  i=2*(ic-xo)+xo;
   d(l+1)%d(ic,jc)=d(l)%d(i,j) - v(l)%d(i,j) +                                          &
&              (v(l)%d(i+1,j)+v(l)%d(i-1,j)+v(l)%d(i,j+1)+v(l)%d(i,j-1))/4
end do; end do
v(l+1)%d=d(l+1)%d;   ! TRICK #3: this is a better initial guess for v{l+1} than v{l+1}=0.
call EnforceBCs(l+1);
! Now CONTINUE DOWN TO COARSER GRID, or SOLVE THE COARSEST SYSTEM (via 20 smooth steps).
! Use same smoother on coarse grid; ie, we SKIP a *4 [i.e., *(delta x)^2] factor (TRICK 2).
if (l<nlev-1) then; call Multigrid(l+1); else; do k=1,20; call Smooth(nlev); end do; end if
! Now perform the PROLONGATION.  TRICK #4: Update black interior points only, as next call
! to Smooth recalculates all red points from scratch, so do not bother updating them here.
! We SKIP a /2 interpolation factor here (Trick 2).
do jc=2,g(l+1)%ym; j=2*(jc-yo)+yo; do ic=2,g(l+1)%xm; i=2*(ic-xo)+xo;
   if (j<=g(l)%ym) then; v(l)%d(i-1,j)=v(l)%d(i-1,j)+(v(l+1)%d(ic-1,jc)+v(l+1)%d(ic,jc));
   end if
   if (i<=g(l)%xm) then; v(l)%d(i,j-1)=v(l)%d(i,j-1)+(v(l+1)%d(ic,jc-1)+v(l+1)%d(ic,jc));
   end if
end do; end do
call EnforceBCs(l)
do k=1,N3; call Smooth(l); end do    ! APPLY SMOOTHING STEPS AFTER COARSENING (N3 times)
end subroutine Multigrid
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine Smooth(l)
! Red/black smoothing with A from Poisson equation scaled to unit diagonal elements.
! The set of points updated first, which we label as "red", includes the corners.
do irb=0,1; do j=2,g(l)%ym-1
   m=2+mod(j+irb+xo+yo,2); n=g(l)%xm-1;  v(l)%d(m:n:2,j) = d(l)%d(m:n:2,j) &
     & + (v(l)%d(m+1:n+1:2,j)+v(l)%d(m-1:n-1:2,j)+v(l)%d(m:n:2,j+1)+v(l)%d(m:n:2,j-1))/4;
end do; call EnforceBCs(l); end do      ! In Fortran, inner loops should be on FIRST index
end subroutine Smooth
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine EnforceBCs(l)
! Enforce the Neumann and periodic boundary conditions (nothing to do for Dirichlet)
i=g(l)%xm-1; j=g(l)%ym-1;
select case(XBC);
   case(3); v(l)%d(1,2:j)=v(l)%d(3,2:j);         v(l)%d(g(l)%xm,2:j)=v(l)%d(g(l)%xm-2,2:j)
   case(2); v(l)%d(1,2:j)=v(l)%d(g(l)%xm-1,2:j); v(l)%d(g(l)%xm,2:j)=v(l)%d(2,2:j)
end select
select case(YBC);
   case(3); v(l)%d(2:i,1)=v(l)%d(2:i,3);         v(l)%d(2:i,g(l)%ym)=v(l)%d(2:i,g(l)%ym-2)
   case(2); v(l)%d(2:i,1)=v(l)%d(2:i,g(l)%ym-1); v(l)%d(2:i,g(l)%ym)=v(l)%d(2:i,2)
end select
end subroutine EnforceBCs
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
real*8 function MaxDefect(l)
MaxDefect = 0.0; do j=2,g(l)%ny; do i=2,g(l)%nx              ! Compute the maximum defect.
   MaxDefect = max(MaxDefect,abs( d(l)%d(i,j) -v(l)%d(i,j) +                            &
&                    ( v(l)%d(i+1,j)+v(l)%d(i-1,j)+v(l)%d(i,j+1)+v(l)%d(i,j-1) )/4))
end do; end do;
end function MaxDefect
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
end program PoissonMG2DTest


program problem64
  use fmzm
  implicit none
  integer            :: i,count
  integer, parameter :: limit=10000

  call fm_set(1000)

  count=0
  do i=1,limit
     if (predicate(i)) count=count+1
  end do

  print *, count

contains

  function predicate(n)
    implicit none
    integer, intent(in) :: n
    integer             :: temp
    logical             :: predicate

    temp=period(n)
    predicate=(mod(temp,2)==1)

  end function predicate

  function period(n)
    use fmzm
    implicit none
    integer, intent(in) :: n
    type(fm)            :: temp1,temp2
    type(fm)            :: cutoff,one
    integer             :: period,i

    cutoff=to_fm(1.0d-10)
    one=to_fm(1.0)

    temp1=mod(sqrt(to_fm(n)),one)
    if (temp1 == 0.0) go to 100

    temp2=mod(one/temp1,one)
    do period=1,huge(period)
       if (abs(temp1-temp2)<cutoff) go to 100
       temp2=mod(one/temp2,one)
    end do

100 continue

  end function period

end program problem64


program t
  integer :: i, j, k
  integer, dimension(3, 3, 3) :: a

  do i = 1, 3
    do j = 1, 3
      do k = 1, 3
        a(i, j, k) = i + j + k
      end do
    end do
  end do

  print *, "Before "
  print *, a

  where ( a(1, :, 1)  > 0 ) &
    a(1, :, 1) = -3

  print *, "After "
  print *, a

end program t


SUBROUTINE spline(x,y,n,yp1,ypn,y2)
  USE healpix_types
  implicit none
      INTEGER, intent(in) :: n
      real(dp), intent(in) :: x(n), y(n), yp1, ypn
      real(dp), intent(out) :: y2(n)
      INTEGER i,k
      real(dp) p,qn,sig,un
      real(dp), dimension(:), allocatable :: u

      write(*,*) 'you are using this one'

      Allocate(u(1:n))
      if (yp1.gt..1d30) then
        y2(1)=0._dp
        u(1)=0._dp
      else
        y2(1)=-0.5d0
        u(1)=(3._dp/(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
      endif

      do i=2,n-1
        sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
        p=sig*y2(i-1)+2._dp

        y2(i)=(sig-1._dp)/p

         u(i)=(6._dp*((y(i+1)-y(i))/(x(i+ &
         1)-x(i))-(y(i)-y(i-1))/(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig* &
         u(i-1))/p
      end do
      if (ypn.gt..1d30) then
        qn=0._dp
        un=0._dp
      else
        qn=0.5d0
        un=(3._dp/(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
      endif
      y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1._dp)
      do k=n-1,1,-1
        y2(k)=y2(k)*y2(k+1)+u(k)
      end do

      Deallocate(u)

!  (C) Copr. 1986-92 Numerical Recipes Software =$j*m,).
      END SUBROUTINE spline


module fibresModelsLib
use funcAux

implicit none

real*8 , parameter :: kappaReg3 = 1.0d-5
real*8 , parameter :: kappaReg2 = 1.0d-8
real*8 , parameter :: kappaReg = 1.0d-8
real*8 , parameter :: rho = 1000.0d0

contains

subroutine derivatives_strainEnergy_fib(dPsi,d2Psi,qfib,matPar,constLaw)
	real*8, intent(in) :: qfib(:) , matPar(:)
	real*8 , intent(out) :: dPsi, d2Psi
	integer , intent(in) :: constLaw
	real*8 :: I4

	I4 = dot_product(qfib,qfib)

	select case(constLaw)
		case(1)
			call dFibreExponential(dPsi,I4,matPar(1:3))
			call d2FibreExponential(d2Psi,I4,matPar(1:3))
		case(2)
			call dFibreLinear(dPsi,I4,matPar(1:3))
			call d2FibreLinear(d2Psi,I4,matPar(1:3))
		case(15)
			call dFibreLinearComp(dPsi,I4,matPar(1:3))
			call d2FibreLinearComp(d2Psi,I4,matPar(1:3))
		case(21)
			call dTrussQuang(dPsi,I4,matPar(1:3))
			call d2TrussQuang(d2Psi,I4,matPar(1:3))
		case(22)
			call dFibreLinearComp_noRecruitment(dPsi,I4,matPar(1:3))
			call d2FibreLinearComp_noRecruitment(d2Psi,I4,matPar(1:3))
		case default
			write(0,*) constLaw, matpar(1:3), "Strain Energy case unknown"
			PAUSE
	end select

end subroutine

subroutine strainEnergy_fib(energy,qfib,matPar,constLaw)
	real*8, intent(in) :: qfib(:) , matPar(:)
	real*8 , intent(out) :: energy
	integer , intent(in) :: constLaw
	real*8 :: I4

	energy = 0.0d0

	I4 = dot_product(qfib,qfib)

	selectcase(constLaw)
		case(1)
			call FibreExponential(energy,I4,matPar(1:3))
		case(2)
			call FibreLinear(energy,I4,matPar(1:3))
		case(3)
			call FibreExponentialReg(energy,I4,matPar(1:3))
		case(4)
			call FibreLinearReg(energy,I4,matPar(1:3))
		case(5)
			call FibreExponentialReg2(energy,I4,matPar(1:3))
		case(6)
			call FibreLinearReg2(energy,I4,matPar(1:3))
		case(7)
			call FibreExponentialReg3(energy,I4,matPar(1:3))
		case(8)
			call FibreLinearReg3(energy,I4,matPar(1:3))
		case(9)
			call FibreExponential2(energy,I4,matPar(1:3))
		case(10)
			call FibreLinear2(energy,I4,matPar(1:3))
		case(11)
			call FibreExponentialVisc(energy,I4,matPar)
		case(12)
			call FibreExponentialCompression(energy,I4,matPar)
		case(13)
			call FibreExponentialNonlinear(energy,I4,matPar)
		case(14)
			call FibreLinear3(energy,I4,matPar(1:3)) ! energy is linear
		case(15)
			call FibreLinearComp(energy,I4,matPar(1:3)) ! energy is linear
		case(16)
			call FibreLinearComp2(energy,I4,matPar(1:3)) ! energy is linear
		case(17)
			call FibreLinearComp3(energy,I4,matPar(1:3)) ! energy is linear
		case(18)
			call FibreLinearComp4(energy,I4,matPar(1:3)) ! energy is linear
		case(19)
			call FibreZullinger(energy,I4,matPar(1:3)) ! energy is linear
		case(20)
			call FibreLinearRegNew(energy,I4,matPar) ! energy is linear
		case(21)
			call TrussQuang(energy,I4,matPar)
		case(22)
			call FibreLinearComp_noRecruitment(energy,I4,matPar(1:3)) ! energy is linear
		case default
			write(0,*) constLaw, matpar(1:3), "Strain Energy case unknown"
			PAUSE
	end select

end subroutine

real*8 function heav(x) result(h)
	real*8, intent(in) :: x

	h = 0.5d0*(dsign(1.0d0,x) + 1.0d0)

!~ 	if(x>0.0d0) then
!~ 		h = 1.0d0
!~ 	else if(x<0.0d0) then
!~ 		h = 0.0d0
!~ 	else
!~ 		h = 0.5d0
!~ 	end if
!~
end function

real*8 function heavReg(x) result(h)
	real*8, intent(in) :: x

	h = 0.5d0*(dsign(1.0d0,x)*(1.0d0 - dexp(-dabs(x)*rho)) + 1.0d0)
!~ 	h = 0.5d0*(dsign(1.0d0,x)*(1.0d0 - dexp(-rho*dabs(x)**0.5d0)) + 1.0d0)

end function

subroutine TrussQuang(Psi,I4,MatPar) ! See Javier Bonet
	real*8 , intent(out) :: Psi
	real*8 , intent(in) :: I4, MatPar(:) ! MatPar is only the material coeficient, a0 was splitted
	real*8 :: E
	E = MatPar(1) !

	Psi = (E/8.0d0)*(I4-1.0d0)**2.0d0

end subroutine

subroutine dTrussQuang(dPsi,I4,MatPar) ! See Javier Bonet
	real*8 , intent(out) :: dPsi
	real*8 , intent(in) :: I4, MatPar(:) ! MatPar is only the material coeficient, a0 was splitted
	real*8 :: E
	E = MatPar(1) !

	dPsi = (E/4.0d0)*(I4-1.0d0)

end subroutine

subroutine d2TrussQuang(d2Psi,I4,MatPar) ! See Javier Bonet
	real*8 , intent(out) :: d2Psi
	real*8 , intent(in) :: I4, MatPar(:) ! MatPar is only the material coeficient, a0 was splitted
	real*8 :: E
	E = MatPar(1) !

	d2Psi = E/4.0d0

end subroutine

subroutine FibreExponentialReg3(Psi,I4,MatPar)
	real*8 , intent(out) :: Psi
	real*8 , intent(in) :: I4, MatPar(:) ! MatPar is only the material coeficient, a0 was splitted
 	real*8 :: c1,c2,lfa, lrel, l

	c1 = MatPar(1) ! k1
	c2 = MatPar(2) ! k2
	lfa = MatPar(3)

	l = dsqrt(I4)
	lrel = l - lfa

	Psi = 0.5d0*(c1/c2)*( heav(lrel)*(Dexp(c2*lrel**2.0d0)-1.0d0) + kappaReg3*(Dexp(c2*l**2.0d0)-1.0d0))

end subroutine

subroutine FibreExponentialReg2(Psi,I4,MatPar)
	real*8 , intent(out) :: Psi
	real*8 , intent(in) :: I4, MatPar(:) ! MatPar is only the material coeficient, a0 was splitted
 	real*8 :: c1,c2,lfa, lrel

	c1 = MatPar(1) ! k1
	c2 = MatPar(2) ! k2
	lfa = MatPar(3)

	lrel = dsqrt(I4) - lfa

	Psi = (heav(lrel) + kappaReg2)*0.5d0*(c1/c2)*( Dexp(c2*lrel**2.0d0)-1.0d0)

end subroutine

subroutine FibreExponentialReg(Psi,I4,MatPar)

	real*8 , intent(out) :: Psi
	real*8 , intent(in) :: I4, MatPar(:) ! MatPar is only the material coeficient, a0 was splitted
 	real*8 :: c1,c2,lfa, lrel

	c1 = MatPar(1) ! k1
	c2 = MatPar(2) ! k2
	lfa = MatPar(3)

	lrel = dsqrt(I4) - lfa

	Psi = heavReg(lrel)*0.5d0*(c1/c2)*( Dexp(c2*lrel**2.0d0)-1.0d0 + kappaReg)

end subroutine

subroutine FibreLinearReg3(Psi,I4,MatPar)
	real*8 , intent(out) :: Psi
	real*8 , intent(in) :: I4, MatPar(:) ! MatPar is only the material coeficient, a0 was splitted
 	real*8 :: c1,lfa, lrel, l

	c1 = MatPar(1) ! k1
	lfa = MatPar(3)

	l = dsqrt(I4)
	lrel = l - lfa

	Psi = (c1/8.0d0)*( heav(lrel)*lrel**2.0d0 + kappaReg3*l**2.0d0)

end subroutine

subroutine FibreLinearReg2(Psi,I4,MatPar) ! see my Wriggers  Sx = E Ex
	real*8 , intent(out) :: Psi
	real*8 , intent(in) :: I4, MatPar(:) ! MatPar is only the material coeficient, a0 was splitted
	real*8 :: c1,lfa, lrel
	c1 = MatPar(1) ! k1
	lfa = MatPar(3)

	lrel = dsqrt(I4) - lfa

	Psi = (heav(lrel) + kappaReg2)*(c1/8.0d0)*lrel**2.0d0

end subroutine

subroutine FibreLinearReg(Psi,I4,MatPar) ! see my Wriggers  Sx = E Ex
	real*8 , intent(out) :: Psi
	real*8 , intent(in) :: I4, MatPar(:) ! MatPar is only the material coeficient, a0 was splitted
	real*8 :: c1,lfa, lrel
	c1 = MatPar(1) ! k1
	lfa = MatPar(3)

	lrel = dsqrt(I4) - lfa

	Psi = heavReg(lrel)*(c1/8.0d0)*(lrel**2.0d0 + kappaReg)

end subroutine

subroutine FibreExponential(Psi,I4,MatPar) ! see my dissertation
	real*8 , intent(out) :: Psi
	real*8 , intent(in) :: I4, MatPar(:) ! MatPar is only the material coeficient, a0 was splitted
 	real*8 :: c1,c2,lfa, lrel
	c1 = MatPar(1) ! k1
	c2 = MatPar(2) ! k2
	lfa = MatPar(3)

	lrel = dsqrt(I4) - lfa

	Psi = heav(lrel)*0.5d0*(c1/c2)*( Dexp(c2*(lrel)**2.0d0)-1.0d0 )

end subroutine

subroutine FibreExponentialCompression(Psi,I4,MatPar) ! see my dissertation
	real*8 , intent(out) :: Psi
	real*8 , intent(in) :: I4, MatPar(:) ! MatPar is only the material coeficient, a0 was splitted
 	real*8 :: c1,c2,lfa, lrel
	c1 = MatPar(1) ! k1
	c2 = MatPar(2) ! k2
	lfa = MatPar(3)

	lrel = I4 - lfa*lfa

	Psi = 0.5d0*(c1/c2)*( Dexp(c2*(lrel)**2.0d0)-1.0d0 )

end subroutine

subroutine FibreExponential2(Psi,I4,MatPar) ! full I4
	real*8 , intent(out) :: Psi
	real*8 , intent(in) :: I4, MatPar(:) ! MatPar is only the material coeficient, a0 was splitted
 	real*8 :: c1,c2,lfa, lrel
	c1 = MatPar(1) ! k1
	c2 = MatPar(2) ! k2
	lfa = MatPar(3)

	lrel = I4 - lfa*lfa

!~ 	write(0,*) "fibreExpVisc = ", c1, c2, lfa

	Psi = heav(lrel)*0.5d0*(c1/c2)*( Dexp(c2*(lrel)**2.0d0)-1.0d0 )

end subroutine

subroutine FibreExponentialVisc(Psi,I4,MatPar) ! with viscosity
	real*8 , intent(out) :: Psi
	real*8 , intent(in) :: I4, MatPar(:) ! MatPar is only the material coeficient, a0 was splitted
 	real*8 :: c1,c2,lfa, lrel, nu_n, nu_k, ln, lk ,l
	c1 = MatPar(1) ! k1
	c2 = MatPar(2) ! k2
	lfa = MatPar(3)
	nu_n = MatPar(4)
	ln = MatPar(5)
	nu_k = MatPar(6)
	lk = MatPar(7)

!~ 	write(0,*) "fibreExpVisc = ", nu_n, ln, nu_k, lk, nu_k*(l - lk)**2.0d0, nu_n*(l - ln)**2.0d0

	lrel = I4 - lfa*lfa
	l = dsqrt(I4)

	Psi = heav(lrel)*0.5d0*(c1/c2)*( dexp(c2*(lrel)**2.0d0)-1.0d0 )
	Psi = Psi + nu_n*(l - ln)**2.0d0
	Psi = Psi + nu_k*(l - lk)**2.0d0

end subroutine

subroutine FibreExponentialNonlinear(Psi,I4,MatPar) ! with viscosity
	real*8 , intent(out) :: Psi
	real*8 , intent(in) :: I4, MatPar(:) ! MatPar is only the material coeficient, a0 was splitted
 	real*8 :: c1,c2,lfa, lrel, nu_n, nu_k, ln, lk, l
	c1 = MatPar(1) ! k1
	c2 = MatPar(2) ! k2
	lfa = MatPar(3)
	nu_n = MatPar(4)
	ln = MatPar(5)
	nu_k = MatPar(6)
	lk = MatPar(7)

	lrel = I4 - lfa*lfa
	l = dsqrt(I4)

!~ 	write(0,*) "fibreExpVisc = ", nu_n, ln, nu_k, lk, l-lk, lrel

	Psi = heav(lrel)*0.5d0*(c1/c2)*( dexp(c2*(lrel)**2.0d0)-1.0d0 )
	Psi = Psi + heav(-lrel)*0.5d0*(c1/c2)*( dexp(c2*(lrel)**2.0d0)-1.0d0 )*nu_n*(l - ln)**2.0d0
	Psi = Psi + heav(-lrel)*0.5d0*(c1/c2)*( dexp(c2*(lrel)**2.0d0)-1.0d0 )*nu_k*(l - lk)**2.0d0

end subroutine

subroutine FibreLinear(Psi,I4,MatPar) ! see my Wriggers  Sx = E Ex
	real*8 , intent(out) :: Psi
	real*8 , intent(in) :: I4, MatPar(:) ! MatPar is only the material coeficient, a0 was splitted
	real*8 :: c1,lfa, lrel
	c1 = MatPar(1) ! k1
	lfa = MatPar(3)

	lrel = dsqrt(I4) - lfa

	Psi = heav(lrel)*(c1/8.0d0)*lrel**2.0d0

end subroutine

subroutine FibreLinear2(Psi,I4,MatPar) ! full I4
	real*8 , intent(out) :: Psi
	real*8 , intent(in) :: I4, MatPar(:) ! MatPar is only the material coeficient, a0 was splitted
	real*8 :: c1,lfa, lrel
	c1 = MatPar(1) ! k1
	lfa = MatPar(3)

	lrel = I4 - lfa*lfa

	Psi = heav(lrel)*(c1/8.0d0)*lrel**2.0d0

end subroutine

subroutine dFibreExponential(dPsi,I4,MatPar) ! see my dissertation
	real*8 , intent(out) :: dPsi
	real*8 , intent(in) :: I4, MatPar(:) ! MatPar is only the material coeficient, a0 was splitted
 	real*8 :: c1,c2,lfa, lrel
	c1 = MatPar(1) ! k1
	c2 = MatPar(2) ! k2
	lfa = MatPar(3)

	lrel = dsqrt(I4) - lfa

	dPsi = heav(lrel)*c1*lrel*Dexp(c2*(lrel)**2.0d0)

end subroutine

subroutine d2FibreExponential(d2Psi,I4,MatPar) ! see my dissertation
	real*8 , intent(out) :: d2Psi
	real*8 , intent(in) :: I4, MatPar(:) ! MatPar is only the material coeficient, a0 was splitted
	real*8 :: c1,c2,lfa, lrel
	c1 = MatPar(1) ! k1
	c2 = MatPar(2) ! k2
	lfa = MatPar(3)

	lrel = dsqrt(I4) - lfa

	d2Psi = heav(lrel)*c1*Dexp(c2*(lrel)**2.0d0)*(1.0d0 + 2.0d0*lrel**2.0d0)

end subroutine

subroutine dFibreLinear(dPsi,I4,MatPar) ! see my Wriggers  Sx = E Ex
	real*8 , intent(out) :: dPsi
	real*8 , intent(in) :: I4, MatPar(:) ! MatPar is only the material coeficient, a0 was splitted
 	real*8 :: c1,lfa, lrel
	c1 = MatPar(1) ! k1
	lfa = MatPar(3)

	lrel = dsqrt(I4) - lfa

	dPsi = heav(lrel)*(c1/4.0d0)*lrel

end subroutine

subroutine d2FibreLinear(d2Psi,I4,MatPar) ! see my Wriggers  Sx = E Ex
	real*8 , intent(out) :: d2Psi
	real*8 , intent(in) :: I4, MatPar(:) ! MatPar is only the material coeficient, a0 was splitted
 	real*8 :: c1, lfa, lrel
	c1 = MatPar(1) ! k1
	lfa = MatPar(3)

	lrel = dsqrt(I4) - lfa

	d2Psi = heav(lrel)*c1/4.0d0

end subroutine

subroutine FibreLinear3(Psi,I4,MatPar)

	real*8 , intent(out) :: Psi
	real*8 , intent(in) :: I4, MatPar(:) ! MatPar is only the material coeficient, a0 was splitted
	real*8 :: c1, c2, lfa, lrel
	c1 = MatPar(1) ! k1
	c2 = MatPar(2) ! k2
	lfa = MatPar(3)

	lrel = dsqrt(I4) - lfa

	Psi = heav(lrel)*(c1/8.0d0)*lrel**2.0d0

	lrel = dsqrt(I4) - 1.0

	Psi = Psi + (c2/8.0d0)*lrel**2.0d0

end subroutine

subroutine FibreLinearComp(Psi,I4,MatPar) ! works on compression

	real*8 , intent(out) :: Psi
	real*8 , intent(in) :: I4, MatPar(:) ! MatPar is only the material coeficient, a0 was splitted
	real*8 :: c1, c2, lfa, lrel
	c1 = MatPar(1) ! k1
	c2 = MatPar(2)
	lfa = MatPar(3)

	lrel = dsqrt(I4) - lfa

	if(lrel > 0.0d0) then
		Psi = (c1/8.0d0)*lrel**2.0d0
	else
		Psi = (c2/8.0d0)*lrel**2.0d0
	end if

end subroutine

subroutine FibreLinearComp_noRecruitment(Psi,I4,MatPar) ! works on compression

	real*8 , intent(out) :: Psi
	real*8 , intent(in) :: I4, MatPar(:) ! MatPar is only the material coeficient, a0 was splitted
	real*8 :: c1, c2, lrel
	c1 = MatPar(1) ! k1
	c2 = MatPar(2)

	lrel = dsqrt(I4) - 1.0d0

	if(lrel > 0.0d0) then
		Psi = (c1/8.0d0)*lrel**2.0d0
	else
		Psi = (c2/8.0d0)*lrel**2.0d0
	end if

end subroutine

subroutine FibreLinearComp2(Psi,I4,MatPar) ! works on compression

	real*8 , intent(out) :: Psi
	real*8 , intent(in) :: I4, MatPar(:) ! MatPar is only the material coeficient, a0 was splitted
	real*8 :: c1, c2, lfa, lrel
	c1 = MatPar(1) ! k1
	c2 = MatPar(2)
	lfa = MatPar(3)

	lrel = dsqrt(I4) - lfa

	if(lrel > 0.0d0) then
		Psi = (c1/8.0d0)*lrel
	else
		Psi = -(c2/8.0d0)*lrel
	end if

end subroutine

subroutine FibreLinearComp3(Psi,I4,MatPar) ! works on compression

	real*8 , intent(out) :: Psi
	real*8 , intent(in) :: I4, MatPar(:) ! MatPar is only the material coeficient, a0 was splitted
	real*8 :: c1, c2, lfa, lrel
	c1 = MatPar(1) ! k1
	c2 = MatPar(2)
	lfa = MatPar(3)

	lrel = I4 - lfa*lfa

	if(lrel > 0.0d0) then
		Psi = (c1/8.0d0)*lrel
	else
		Psi = -(c2/8.0d0)*lrel
	end if

end subroutine

subroutine FibreLinearComp4(Psi,I4,MatPar) ! works on compression

	real*8 , intent(out) :: Psi
	real*8 , intent(in) :: I4, MatPar(:) ! MatPar is only the material coeficient, a0 was splitted
	real*8 :: c1, c2, lfa, lrel
	c1 = MatPar(1) ! k1
	c2 = MatPar(2)
	lfa = MatPar(3)

	lrel = I4 - lfa*lfa

	if(lrel > 0.0d0) then
		Psi = (c1/8.0d0)*lrel**2.0d0
	else
		Psi = (c2/8.0d0)*lrel**2.0d0
	end if

end subroutine

subroutine FibreZullinger(Psi,I4,MatPar) ! works on compression
	real*8 , intent(out) :: Psi
	real*8 , intent(in) :: I4, MatPar(:) ! MatPar is only the material coeficient, a0 was splitted
	real*8 :: c1, c2, lfa, lrel
	c1 = MatPar(1) ! k1
	c2 = MatPar(2)
	lfa = MatPar(3)

	lrel = dsqrt(I4) - lfa

	if(lrel > 0.0d0) then
		Psi = c1*(lrel - dlog(lrel + 1.0d0))
	else
		Psi = -c2*lrel
	end if

end subroutine

subroutine FibreLinearRegNew(Psi,I4,MatPar) ! works on compression
	real*8 , intent(out) :: Psi
	real*8 , intent(in) :: I4, MatPar(:) ! MatPar is only the material coeficient, a0 was splitted
	real*8 :: k1, k2, lfa, l1, l2, l3, eps, delta, l, dl21, dl32, alpha
	real*8 :: a0, a1, a2, b0, b1, b2, b3, c0, c1, c2
	real*8 , parameter :: tol = 1.0e-15

	k1 = MatPar(1)
	k2 = MatPar(2)
	lfa = MatPar(3) !! reserved entry, given by param, should be 0.0 in commonPar
	l1 = MatPar(4)
	delta = MatPar(5)
	eps = MatPar(6)

	if(l1<0.0d0) then
		l1 = lfa
	end if

	l2 = lfa - delta*(lfa-l1)
	l3 = lfa + delta*(lfa-l1)

	l = dsqrt(I4)
	dl21 = l2 - l1
	dl32 = l3 - l2
	alpha = (k2 - k1)/dl32

	if((k2-k1)<tol .and. dl32 < tol) then
		alpha = 0.0d0
	else
		alpha = (k2 - k1)/dl32
	end if

	a0 = 0.0d0
	b0 = eps
	a2 = 0.5d0*k1
	b2 = 0.5d0*k1
	c2 = 0.5d0*k2
	b3 = alpha/6.0d0
	if((b0-a0)<tol .and. dl21 < tol) then
		a1 = 0.0d0
	else
		a1 = (b0 - a0)/dl21 - a2*dl21
	end if

	b1 = 2.0d0*a2*dl21 + a1
	c1 = 3.0d0*b3*dl32**2.0d0 + 2.0d0*b2*dl32 + b1
	c0 = b3*dl32**3.0d0 + b2*dl32**2.0d0 + b1*dl32 + b0

	Psi = 0.0d0

!~ 	if(l<l1) then
!~ 		Psi = a0
	if(l < l2) then
		Psi = a2*(l-l1)**2.0d0 + a1*(l-l1) + a0
	else if (l < l3) then
		Psi = b3*(l-l2)**3.0d0 + b2*(l-l2)**2.0d0 + b1*(l-l2) + b0
	else
		Psi = c2*(l-l3)**2.0d0 + c1*(l-l3) + c0
	end if

end subroutine

subroutine dFibreLinearComp(dPsi,I4,MatPar) ! see my Wriggers  Sx = E Ex
	real*8 , intent(out) :: dPsi
	real*8 , intent(in) :: I4, MatPar(:) ! MatPar is only the material coeficient, a0 was splitted
 	real*8 :: c1, c2,lfa, lrel
	c1 = MatPar(1) ! k1
	c2 = MatPar(2) ! k2
	lfa = MatPar(3)

	lrel = dsqrt(I4) - lfa

	if(lrel >= 0.0d0) then
		dPsi = (c1/8.0)*lrel/(lrel + lfa)
	else
		dPsi = (c2/8.0)*lrel/(lrel + lfa)
	end if

end subroutine

subroutine d2FibreLinearComp(d2Psi,I4,MatPar) ! see my Wriggers  Sx = E Ex
	real*8 , intent(out) :: d2Psi
	real*8 , intent(in) :: I4, MatPar(:) ! MatPar is only the material coeficient, a0 was splitted
 	real*8 :: c1, c2, lfa, lrel
	c1 = MatPar(1) ! k1
	c2 = MatPar(2) ! k1
	lfa = MatPar(3)

	lrel = dsqrt(I4) - lfa

	if(lrel >= 0.0d0) then
		d2Psi = (c1/16.0d0)*lfa*(lrel+lfa)**(-3.0d0)
	else
		d2Psi = (c2/16.0d0)*lfa*(lrel+lfa)**(-3.0d0)
	end if

end subroutine

subroutine dFibreLinearComp_noRecruitment(dPsi,I4,MatPar) ! see my Wriggers  Sx = E Ex
	real*8 , intent(out) :: dPsi
	real*8 , intent(in) :: I4, MatPar(:) ! MatPar is only the material coeficient, a0 was splitted
 	real*8 :: c1, c2, lrel
	c1 = MatPar(1) ! k1
	c2 = MatPar(2) ! k2

	lrel = dsqrt(I4) - 1.0d0

	if(lrel >= 0.0d0) then
		dPsi = (c1/8.0)*lrel/(lrel + 1.0d0)
	else
		dPsi = (c2/8.0)*lrel/(lrel + 1.0d0)
	end if

end subroutine

subroutine d2FibreLinearComp_noRecruitment(d2Psi,I4,MatPar) ! see my Wriggers  Sx = E Ex
	real*8 , intent(out) :: d2Psi
	real*8 , intent(in) :: I4, MatPar(:) ! MatPar is only the material coeficient, a0 was splitted
 	real*8 :: c1, c2, lrel
	c1 = MatPar(1) ! k1
	c2 = MatPar(2) ! k1

	lrel = dsqrt(I4) - 1.0d0

	if(lrel >= 0.0d0) then
		d2Psi = (c1/16.0d0)*1.0d0*(lrel+1.0d0)**(-3.0d0)
	else
		d2Psi = (c2/16.0d0)*1.0d0*(lrel+1.0d0)**(-3.0d0)
	end if

end subroutine

end module


!***********************************************************************************************************************************
! UNIT:
!
!  (MODULE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  MODULE MR_MOD_FUNC_TCRS

    USE MR_KINDS

    USE MR_DEF_CONSTS_N_REF_PARS

    IMPLICIT NONE

    PRIVATE

    PUBLIC :: MR_FUNC_TCRS

    INTERFACE MR_FUNC_TCRS
      MODULE PROCEDURE MR_FUNC_TCRS_PARD_KIND
      MODULE PROCEDURE MR_FUNC_TCRS_FDRD_KIND
    END INTERFACE

!***********************************************************************************************************************************

  CONTAINS

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  FUNCTION MR_FUNC_TCRS_PARD_KIND( DS ) RESULT( TCRS )

    IMPLICIT NONE

    REAL(PARD_KIND) , INTENT(IN ) :: DS

    REAL(PARD_KIND) :: TCRS

    TCRS = RBT / FR * (SS-1.0) * ( DS * DSPAR ) *   &
    ( 0.130 *           EXP( -0.015 * DS * DS ) / (DS**0.392)   &
    + 0.045 * ( 1.000 - EXP( -0.068 *   DS    )               )   &
    )

  END FUNCTION MR_FUNC_TCRS_PARD_KIND

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  FUNCTION MR_FUNC_TCRS_FDRD_KIND( DS ) RESULT( TCRS )

    IMPLICIT NONE

    REAL(FDRD_KIND) , INTENT(IN ) :: DS

    REAL(FDRD_KIND) :: TCRS

    TCRS = RBT / FR * (SS-1.0) * ( DS * DSPAR ) *   &
    ( 0.130 *           EXP( -0.015 * DS * DS ) / (DS**0.392)   &
    + 0.045 * ( 1.000 - EXP( -0.068 *   DS    )               )   &
    )

  END FUNCTION MR_FUNC_TCRS_FDRD_KIND

  END MODULE MR_MOD_FUNC_TCRS


subroutine evaluate_tidalfield(peps,ppos,ptide)
 include 'globals.h'
 real,intent(in) :: ppos(3),peps
 real,intent(inout) :: ptide(6)

 ptide(1:6)=0
 if(selfgrav) call system_tidalfield(peps,ppos,ptide)
 if(fixthalo) call halotidalfield(ppos,ptide)

end subroutine

subroutine system_tidalfield(peps,ppos,ptide)
 include 'globals.h'
 real,intent(in) :: ppos(3),peps
 real,intent(inout) :: ptide(6)
 integer i,nterms
! periodic -
  if(.NOT.directsum) then
   nterms=0
   call treewalk(root,ppos,peps,0.,0.,nterms)
  else
   nterms=nbodies
   do i=1,nbodies
    bodlist(i)=i
   enddo
  endif
  call tidalsum(peps,ppos,ptide,nterms)
end subroutine

subroutine tidalsum(peps,ppos,ptide,nterms)
 include 'globals.h'
 integer, intent(in):: nterms
 real,intent(in) :: peps,ppos(3)
 real,intent(inout):: ptide(6)
 real :: dx,dy,dz,dist2,dist,epseff,epseffi,drdeldrg, &
  &  rinveff,r3inveff,r5inveff,drsm,rhinv
 integer :: i,q,smindex
 do i=1,nterms
   q=bodlist(i)
   dx=ppos(1)-pos(q,1)
   dy=ppos(2)-pos(q,2)
   dz=ppos(3)-pos(q,3)
   dist2=dx*dx+dy*dy+dz*dz
   dist=SQRT(dist2)
   epseff=peps+epsgrav(q)
   if(dist.GE.epseff) then
    rinveff=1./dist
    r3inveff=rinveff**3
    r5inveff=rinveff**5
   else
    epseffi=1./epseff
    rhinv=dist*epseffi
    if(rhinv.LT.0.5) then
      r3inveff=4./3.+rhinv**2*(4.*rhinv-4.8)
      r5inveff=12*rhinv-9.6
    else
      r3inveff=8./3.-6.*rhinv+4.8*rhinv**2- &
            4./3.*rhinv**3-1./120./rhinv**3
      r5inveff=9.6-4.*rhinv-6./rhinv+1./40./rhinv**5
    endif
    r3inveff=r3inveff*8*epseffi**3
    r5inveff=-r5inveff*8./3.*epseffi**5
   endif

   ptide(1)=ptide(1)+mass(q)*(-r3inveff+3*r5inveff*dx**2)
   ptide(4)=ptide(4)+mass(q)*(-r3inveff+3*r5inveff*dy**2)
   ptide(6)=ptide(6)+mass(q)*(-r3inveff+3*r5inveff*dz**2)
   ptide(2)=ptide(2)+mass(q)*3*r5inveff*dx*dy
   ptide(3)=ptide(3)+mass(q)*3*r5inveff*dx*dz
   ptide(5)=ptide(5)+mass(q)*3*r5inveff*dy*dz

   if(usequad.AND.q.GE.nbods1) then
    call terror("tide+quad tbd")
   endif

 enddo
end subroutine tidalsum


      SUBROUTINE MFFTDM(C,IMSX,IVSX,IESX,NMX,NVX,NEX,TABLES,IERR)
*   PURPOSE:
*       THIS SUBROUTINE PERFORMS A DIRECT FOURIER TRANSFORM ALONG
*       THE SECOND DIMENSION OF A 3-DIMENSIONAL MATRIX, USING THE
*       GENTLEMAN-SANDE ALGORITHM.
*       THE SEQUENCE TO BE TRANSFORMED IS C[IMSX,NMX], WHOSE COMPONENTS
*       ARE THE 2-VECTORS C(M)[IVSX,NVX [IESX,NEX]].
*       SEE REF.[1] FOR NOTATIONS.
*  EXAMPLE:
*       LET C BE A 3-D MATRIX C(N1,N2,N3), DECLARED VIA
*              DIMENSION C(NN1,N2,N3)
*       WITH NN1.GE.N1
*       THEN ITS DFT ALONG THE SECOND DIMENSION IS OBTAINED BY
*              CALL MFFTDM(C,NN1,NN1*N2,1,N2,N3,N1,TABLES,IERR)
*  IMPLEMENTATION:
*       THE TRANSFORMATION IS IMPLEMENTED THROUGH REPEATED CALLS TO THE
*       "BUTTERFLY" TRANSFORMATION MFFT?6; PARAMETERS OF THE "BUTTERFLY"
*       ARE COMMUNICATED THROUGH THE COMMON BLOCK MFFTPA.
*  ARGUMENTS:
*    INPUT  :
*       C : ARRAY TO BE TRANSFORMED.
*       IMSX,IVSX,IESX,NMX,NVX,NEX: THESE ARGUMENTS DEFINE THE STRUCTURE
*           OF C ACCORDING TO THE DEFINITIONS ABOVE. THEY ARE UNCHANGED
*           ON OUTPUT
*       TABLES : ARRAY PREPARED BY MFFTP. IT  IS NOT CHANGED ON OUTPUT.
*                IT SHOULD BE DECLARED INTEGER TABLES(4*NM+14);
*                IT MUST BE INITIALIZED BY MFFTP BEFORE USAGE.
*    OUTPUT:
*       C : TRANSFORM OF THE ORIGINAL ARRAY; "BIT REVERSED" ORDER
*       IERR : ERROR CODE : =0 : SUCCESSFUL
*                         : =3 :  'TABLES' NOT CORRECTLY INITIALIZED
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE COMPLEX C(*)
      INTEGER TABLES(-14:*)
      INTEGER IDERR,FACERR,TBERR
      PARAMETER (IDERR=1,FACERR=2,TBERR=3)
      COMMON /MFFTPA/  IMS,IVS,IES,NM,NV,NE,MX,LX,MLIM,MSTEP,LLIM,LSTEP,
     $ NUSTEP,IVLIM,ILIM,MD2LIM,LD2LIM
*  LOADING THE COMMON BLOCK : CONSTANTS
      IMS=IMSX
      IVS=IVSX
      IES=IESX
      NM=NMX
      NV=NVX
      NE=NEX

      IVLIM=(NV-1)*IVS
      ILIM=(NE-1)*IES
      MSTEP=IMS
*  LOADING THE COMMON BLOCK : ITERATION-DEPENDENT QUANTITIES: INITIALIZA
      LX=1
      MX=NM
*  SELECT THE HIGHEST FACTOR OF NM
      IFAC=TABLES(-1)
      GOTO(200,300,500)IFAC
      IERR=TBERR
      RETURN
*...  RADIX 5 LOOP
500   CONTINUE
      DO 510 IM=1,TABLES(-12)
        MX=MX/5
        NUSTEP=MX*MSTEP
        MLIM=NUSTEP-MSTEP
        LSTEP=NUSTEP*5
        LLIM=NM*MSTEP-LSTEP
        CALL MFFTC6(C,TABLES(0))
        LX=LX*5
510   CONTINUE
*..  RADIX 3 LOOP
300   CONTINUE
      DO 310 IM=1,TABLES(-13)
        MX=MX/3
        NUSTEP=MX*MSTEP
        MLIM=NUSTEP-MSTEP
        LSTEP=NUSTEP*3
        LLIM=NM*MSTEP-LSTEP
        CALL MFFTB6(C,TABLES(0))
        LX=LX*3
310   CONTINUE
*..  RADIX 2 LOOP
200   CONTINUE
      DO 210 IM=1,TABLES(-14)
        MX=MX/2
        NUSTEP=MX*MSTEP
        MLIM=NUSTEP-MSTEP
        MD2LIM=NUSTEP/2-MSTEP
        LSTEP=NUSTEP*2
        LLIM=NM*MSTEP-LSTEP
        CALL MFFTA6(C,TABLES(0))
        LX=LX+LX
210   CONTINUE
      END


subroutine compute_longwave(nlev, beta, sigma, T, tau, Tsurf, up, down)

!----------------------------------!
!  Computes two-stream LW fluxes   !
!  using the Schwarzchild eqns.    !
!  J.L. Mitchell 10Mar05           !
!__________________________________!

integer nlev

! T field is defined at midlevel
real,dimension(nlev) :: T

! Flux up and down, lw flux, and tau are defined at level interfaces
real,dimension(0:nlev)   :: tau,up,down
real Tsurf,dtau,sigma,beta

! Upward stream -> d(up)/d(tau) = -up + sigma*T**4
up       = 0.
up(nlev) = sigma*Tsurf**4  ! Surface boundary condition
do k=nlev-1,0,-1
   dtau  = tau(k)-tau(k+1)
   up(k) = up(k+1)*exp(-dtau)                   &
         + sigma*T(k+1)**4.*(1. - exp(-dtau))
enddo

! Downward stream -> d(dn)/d(tau) = dn - sigma*T**4
down(0)    = 0.  ! TOA boundary condition
do k=1,nlev
   dtau    = tau(k) - tau(k-1)
   down(k) = down(k-1)*exp(dtau) - sigma*T(k)**4.*(exp(dtau) - 1.)
enddo

! semi grey
up   = beta*up + (1.-beta)*sigma*Tsurf**4
down = beta*down

end subroutine compute_longwave

! - - - > midlevel
! ----- > surface/interface

!- - - - - - - - - - - - kappa(0),T(0)                  tau big, p small
!----------------------- press(0),tau(0),up/down(0)
!- - - - - - - - - - - - kappa(1),T(1)
!----------------------- press(1)
!- - - - - - - - - - - -   ..
!-----------------------   ..
!- - - - - - - - - - - -   ..
!----------------------- press(nlev-1)
!- - - - - - - - - - - - kappa(nlev)
!----------------------- press(nlev)
!- - - - - - - - - - - - kappa(nlev+1)                  tau small, p big


      SUBROUTINE MD03AD( XINIT, ALG, STOR, UPLO, FCN, JPJ, M, N, ITMAX,
     $                   NPRINT, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2,
     $                   LDPAR2, X, NFEV, NJEV, TOL, CGTOL, DWORK,
     $                   LDWORK, IWARN, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To minimize the sum of the squares of m nonlinear functions, e, in
C     n variables, x, by a modification of the Levenberg-Marquardt
C     algorithm, using either a Cholesky-based or a conjugate gradients
C     solver. The user must provide a subroutine FCN which calculates
C     the functions and the Jacobian J (possibly by finite differences),
C     and another subroutine JPJ, which computes either J'*J + par*I
C     (if ALG = 'D'), or (J'*J + par*I)*x (if ALG = 'I'), where par is
C     the Levenberg factor, exploiting the possible structure of the
C     Jacobian matrix. Template implementations of these routines are
C     included in the SLICOT Library.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     XINIT   CHARACTER*1
C             Specifies how the variables x are initialized, as follows:
C             = 'R' :  the array X is initialized to random values; the
C                      entries DWORK(1:4) are used to initialize the
C                      random number generator: the first three values
C                      are converted to integers between 0 and 4095, and
C                      the last one is converted to an odd integer
C                      between 1 and 4095;
C             = 'G' :  the given entries of X are used as initial values
C                      of variables.
C
C     ALG     CHARACTER*1
C             Specifies the algorithm used for solving the linear
C             systems involving a Jacobian matrix J, as follows:
C             = 'D' :  a direct algorithm, which computes the Cholesky
C                      factor of the matrix J'*J + par*I is used;
C             = 'I' :  an iterative Conjugate Gradients algorithm, which
C                      only needs the matrix J, is used.
C             In both cases, matrix J is stored in a compressed form.
C
C     STOR    CHARACTER*1
C             If ALG = 'D', specifies the storage scheme for the
C             symmetric matrix J'*J, as follows:
C             = 'F' :  full storage is used;
C             = 'P' :  packed storage is used.
C             The option STOR = 'F' usually ensures a faster execution.
C             This parameter is not relevant if ALG = 'I'.
C
C     UPLO    CHARACTER*1
C             If ALG = 'D', specifies which part of the matrix J'*J
C             is stored, as follows:
C             = 'U' :  the upper triagular part is stored;
C             = 'L' :  the lower triagular part is stored.
C             The option UPLO = 'U' usually ensures a faster execution.
C             This parameter is not relevant if ALG = 'I'.
C
C     Function Parameters
C
C     FCN     EXTERNAL
C             Subroutine which evaluates the functions and the Jacobian.
C             FCN must be declared in an external statement in the user
C             calling program, and must have the following interface:
C
C             SUBROUTINE FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1,
C            $                DPAR2, LDPAR2, X, NFEVL, E, J, LDJ, JTE,
C            $                DWORK, LDWORK, INFO )
C
C             where
C
C             IFLAG   (input/output) INTEGER
C                     On entry, this parameter must contain a value
C                     defining the computations to be performed:
C                     = 0 :  Optionally, print the current iterate X,
C                            function values E, and Jacobian matrix J,
C                            or other results defined in terms of these
C                            values. See the argument NPRINT of MD03AD.
C                            Do not alter E and J.
C                     = 1 :  Calculate the functions at X and return
C                            this vector in E. Do not alter J.
C                     = 2 :  Calculate the Jacobian at X and return
C                            this matrix in J. Also return J'*e in JTE
C                            and NFEVL (see below). Do not alter E.
C                     = 3 :  Do not compute neither the functions nor
C                            the Jacobian, but return in LDJ and
C                            IPAR/DPAR1,DPAR2 (some of) the integer/real
C                            parameters needed.
C                     On exit, the value of this parameter should not be
C                     changed by FCN unless the user wants to terminate
C                     execution of MD03AD, in which case IFLAG must be
C                     set to a negative integer.
C
C             M       (input) INTEGER
C                     The number of functions.  M >= 0.
C
C             N       (input) INTEGER
C                     The number of variables.  M >= N >= 0.
C
C             IPAR    (input/output) INTEGER array, dimension (LIPAR)
C                     The integer parameters describing the structure of
C                     the Jacobian matrix or needed for problem solving.
C                     IPAR is an input parameter, except for IFLAG = 3
C                     on entry, when it is also an output parameter.
C                     On exit, if IFLAG = 3, IPAR(1) contains the length
C                     of the array J, for storing the Jacobian matrix,
C                     and the entries IPAR(2:5) contain the workspace
C                     required by FCN for IFLAG = 1, FCN for IFLAG = 2,
C                     JPJ for ALG = 'D', and JPJ for ALG = 'I',
C                     respectively.
C
C             LIPAR   (input) INTEGER
C                     The length of the array IPAR.  LIPAR >= 5.
C
C             DPAR1   (input/output) DOUBLE PRECISION array, dimension
C                     (LDPAR1,*) or (LDPAR1)
C                     A first set of real parameters needed for
C                     describing or solving the problem.
C                     DPAR1 can also be used as an additional array for
C                     intermediate results when computing the functions
C                     or the Jacobian. For control problems, DPAR1 could
C                     store the input trajectory of a system.
C
C             LDPAR1  (input) INTEGER
C                     The leading dimension or the length of the array
C                     DPAR1, as convenient.  LDPAR1 >= 0.  (LDPAR1 >= 1,
C                     if leading dimension.)
C
C             DPAR2   (input/output) DOUBLE PRECISION array, dimension
C                     (LDPAR2,*) or (LDPAR2)
C                     A second set of real parameters needed for
C                     describing or solving the problem.
C                     DPAR2 can also be used as an additional array for
C                     intermediate results when computing the functions
C                     or the Jacobian. For control problems, DPAR2 could
C                     store the output trajectory of a system.
C
C             LDPAR2  (input) INTEGER
C                     The leading dimension or the length of the array
C                     DPAR2, as convenient.  LDPAR2 >= 0.  (LDPAR2 >= 1,
C                     if leading dimension.)
C
C             X       (input) DOUBLE PRECISION array, dimension (N)
C                     This array must contain the value of the
C                     variables x where the functions or the Jacobian
C                     must be evaluated.
C
C             NFEVL   (input/output) INTEGER
C                     The number of function evaluations needed to
C                     compute the Jacobian by a finite difference
C                     approximation.
C                     NFEVL is an input parameter if IFLAG = 0, or an
C                     output parameter if IFLAG = 2. If the Jacobian is
C                     computed analytically, NFEVL should be set to a
C                     non-positive value.
C
C             E       (input/output) DOUBLE PRECISION array,
C                     dimension (M)
C                     This array contains the value of the (error)
C                     functions e evaluated at X.
C                     E is an input parameter if IFLAG = 0 or 2, or an
C                     output parameter if IFLAG = 1.
C
C             J       (input/output) DOUBLE PRECISION array, dimension
C                     (LDJ,NC), where NC is the number of columns
C                     needed.
C                     This array contains a possibly compressed
C                     representation of the Jacobian matrix evaluated
C                     at X. If full Jacobian is stored, then NC = N.
C                     J is an input parameter if IFLAG = 0, or an output
C                     parameter if IFLAG = 2.
C
C             LDJ     (input/output) INTEGER
C                     The leading dimension of array J.  LDJ >= 1.
C                     LDJ is essentially used inside the routines FCN
C                     and JPJ.
C                     LDJ is an input parameter, except for IFLAG = 3
C                     on entry, when it is an output parameter.
C                     It is assumed in MD03AD that LDJ is not larger
C                     than needed.
C
C             JTE     (output) DOUBLE PRECISION array, dimension (N)
C                     If IFLAG = 2, the matrix-vector product J'*e.
C
C             DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C                     The workspace array for subroutine FCN.
C                     On exit, if INFO = 0, DWORK(1) returns the optimal
C                     value of LDWORK.
C
C             LDWORK  (input) INTEGER
C                     The size of the array DWORK (as large as needed
C                     in the subroutine FCN).  LDWORK >= 1.
C
C             INFO    INTEGER
C                     Error indicator, set to a negative value if an
C                     input (scalar) argument is erroneous, and to
C                     positive values for other possible errors in the
C                     subroutine FCN. The LAPACK Library routine XERBLA
C                     should be used in conjunction with negative INFO.
C                     INFO must be zero if the subroutine finished
C                     successfully.
C
C             Parameters marked with "(input)" must not be changed.
C
C     JPJ     EXTERNAL
C             Subroutine which computes J'*J + par*I, if ALG = 'D', and
C             J'*J*x + par*x, if ALG = 'I', where J is the Jacobian as
C             described above.
C
C             JPJ must have the following interface:
C
C             SUBROUTINE JPJ( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR,
C            $                J, LDJ, JTJ, LDJTJ, DWORK, LDWORK, INFO )
C
C             if ALG = 'D', and
C
C             SUBROUTINE JPJ( N, IPAR, LIPAR, DPAR, LDPAR, J, LDJ, X,
C            $                INCX, DWORK, LDWORK, INFO )
C
C             if ALG = 'I', where
C
C             STOR    (input) CHARACTER*1
C                     Specifies the storage scheme for the symmetric
C                     matrix J'*J, as follows:
C                     = 'F' :  full storage is used;
C                     = 'P' :  packed storage is used.
C
C             UPLO    (input) CHARACTER*1
C                     Specifies which part of the matrix J'*J is stored,
C                     as follows:
C                     = 'U' :  the upper triagular part is stored;
C                     = 'L' :  the lower triagular part is stored.
C
C             N       (input) INTEGER
C                     The number of columns of the matrix J.  N >= 0.
C
C             IPAR    (input) INTEGER array, dimension (LIPAR)
C                     The integer parameters describing the structure of
C                     the Jacobian matrix.
C
C             LIPAR   (input) INTEGER
C                     The length of the array IPAR.  LIPAR >= 0.
C
C             DPAR    (input) DOUBLE PRECISION array, dimension (LDPAR)
C                     DPAR(1) must contain an initial estimate of the
C                     Levenberg-Marquardt parameter, par.  DPAR(1) >= 0.
C
C             LDPAR   (input) INTEGER
C                     The length of the array DPAR.  LDPAR >= 1.
C
C             J       (input) DOUBLE PRECISION array, dimension
C                     (LDJ, NC), where NC is the number of columns.
C                     The leading NR-by-NC part of this array must
C                     contain the (compressed) representation of the
C                     Jacobian matrix J, where NR is the number of rows
C                     of J (function of IPAR entries).
C
C             LDJ     (input) INTEGER
C                     The leading dimension of array J.
C                     LDJ >= MAX(1,NR).
C
C             JTJ     (output) DOUBLE PRECISION array,
C                              dimension (LDJTJ,N),    if STOR = 'F',
C                              dimension (N*(N+1)/2),  if STOR = 'P'.
C                     The leading N-by-N (if STOR = 'F'), or N*(N+1)/2
C                     (if STOR = 'P') part of this array contains the
C                     upper or lower triangle of the matrix J'*J+par*I,
C                     depending on UPLO = 'U', or UPLO = 'L',
C                     respectively, stored either as a two-dimensional,
C                     or one-dimensional array, depending on STOR.
C
C             LDJTJ   (input) INTEGER
C                     The leading dimension of the array JTJ.
C                     LDJTJ >= MAX(1,N), if STOR = 'F'.
C                     LDJTJ >= 1,        if STOR = 'P'.
C
C             DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C                     The workspace array for subroutine JPJ.
C
C             LDWORK  (input) INTEGER
C                     The size of the array DWORK (as large as needed
C                     in the subroutine JPJ).
C
C             INFO    INTEGER
C                     Error indicator, set to a negative value if an
C                     input (scalar) argument is erroneous, and to
C                     positive values for other possible errors in the
C                     subroutine JPJ. The LAPACK Library routine XERBLA
C                     should be used in conjunction with negative INFO
C                     values. INFO must be zero if the subroutine
C                     finished successfully.
C
C             If ALG = 'I', the parameters in common with those for
C             ALG = 'D', have the same meaning, and the additional
C             parameters are:
C
C             X       (input/output) DOUBLE PRECISION array, dimension
C                     (1+(N-1)*INCX)
C                     On entry, this incremented array must contain the
C                     vector x.
C                     On exit, this incremented array contains the value
C                     of the matrix-vector product (J'*J + par)*x.
C
C             INCX    (input) INTEGER
C                     The increment for the elements of X.  INCX > 0.
C
C             Parameters marked with "(input)" must not be changed.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of functions.  M >= 0.
C
C     N       (input) INTEGER
C             The number of variables.  M >= N >= 0.
C
C     ITMAX   (input) INTEGER
C             The maximum number of iterations.  ITMAX >= 0.
C
C     NPRINT  (input) INTEGER
C             This parameter enables controlled printing of iterates if
C             it is positive. In this case, FCN is called with IFLAG = 0
C             at the beginning of the first iteration and every NPRINT
C             iterations thereafter and immediately prior to return,
C             with X, E, and J available for printing. If NPRINT is not
C             positive, no special calls of FCN with IFLAG = 0 are made.
C
C     IPAR    (input) INTEGER array, dimension (LIPAR)
C             The integer parameters needed, for instance, for
C             describing the structure of the Jacobian matrix, which
C             are handed over to the routines FCN and JPJ.
C             The first five entries of this array are modified
C             internally by a call to FCN (with IFLAG = 3), but are
C             restored on exit.
C
C     LIPAR   (input) INTEGER
C             The length of the array IPAR.  LIPAR >= 5.
C
C     DPAR1   (input/output) DOUBLE PRECISION array, dimension
C             (LDPAR1,*) or (LDPAR1)
C             A first set of real parameters needed for describing or
C             solving the problem. This argument is not used by MD03AD
C             routine, but it is passed to the routine FCN.
C
C     LDPAR1  (input) INTEGER
C             The leading dimension or the length of the array DPAR1, as
C             convenient.  LDPAR1 >= 0.  (LDPAR1 >= 1, if leading
C             dimension.)
C
C     DPAR2   (input/output) DOUBLE PRECISION array, dimension
C             (LDPAR2,*) or (LDPAR2)
C             A second set of real parameters needed for describing or
C             solving the problem. This argument is not used by MD03AD
C             routine, but it is passed to the routine FCN.
C
C     LDPAR2  (input) INTEGER
C             The leading dimension or the length of the array DPAR2, as
C             convenient.  LDPAR2 >= 0.  (LDPAR2 >= 1, if leading
C             dimension.)
C
C     X       (input/output) DOUBLE PRECISION array, dimension (N)
C             On entry, if XINIT = 'G', this array must contain the
C             vector of initial variables x to be optimized.
C             If XINIT = 'R', this array need not be set before entry,
C             and random values will be used to initialize x.
C             On exit, if INFO = 0, this array contains the vector of
C             values that (approximately) minimize the sum of squares of
C             error functions. The values returned in IWARN and
C             DWORK(1:5) give details on the iterative process.
C
C     NFEV    (output) INTEGER
C             The number of calls to FCN with IFLAG = 1. If FCN is
C             properly implemented, this includes the function
C             evaluations needed for finite difference approximation
C             of the Jacobian.
C
C     NJEV    (output) INTEGER
C             The number of calls to FCN with IFLAG = 2.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             If TOL >= 0, the tolerance which measures the relative
C             error desired in the sum of squares. Termination occurs
C             when the actual relative reduction in the sum of squares
C             is at most TOL. If the user sets  TOL < 0, then  SQRT(EPS)
C             is used instead TOL, where EPS is the machine precision
C             (see LAPACK Library routine DLAMCH).
C
C     CGTOL   DOUBLE PRECISION
C             If ALG = 'I' and CGTOL > 0, the tolerance which measures
C             the relative residual of the solutions computed by the
C             conjugate gradients (CG) algorithm. Termination of a
C             CG process occurs when the relative residual is at
C             most CGTOL. If the user sets  CGTOL <= 0, then  SQRT(EPS)
C             is used instead CGTOL.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK, DWORK(2) returns the residual error norm (the
C             sum of squares), DWORK(3) returns the number of iterations
C             performed, DWORK(4) returns the total number of conjugate
C             gradients iterations performed (zero, if ALG = 'D'), and
C             DWORK(5) returns the final Levenberg factor.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= max( 5, M + 2*N + size(J) +
C                            max( DW( FCN|IFLAG = 1 ) + N,
C                                 DW( FCN|IFLAG = 2 ),
C                                 DW( sol ) ) ),
C             where size(J) is the size of the Jacobian (provided by FCN
C             in IPAR(1), for IFLAG = 3), DW( f ) is the workspace
C             needed by the routine f, where f is FCN or JPJ (provided
C             by FCN in IPAR(2:5), for IFLAG = 3), and DW( sol ) is the
C             workspace needed for solving linear systems,
C             DW( sol ) = N*N + DW( JPJ ),  if ALG = 'D', STOR = 'F';
C             DW( sol ) = N*(N+1)/2 + DW( JPJ ),
C                                           if ALG = 'D', STOR = 'P';
C             DW( sol ) = 3*N + DW( JPJ ),  if ALG = 'I'.
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             < 0:  the user set IFLAG = IWARN in the subroutine FCN;
C             = 0:  no warning;
C             = 1:  if the iterative process did not converge in ITMAX
C                   iterations with tolerance TOL;
C             = 2:  if ALG = 'I', and in one or more iterations of the
C                   Levenberg-Marquardt algorithm, the conjugate
C                   gradient algorithm did not finish after 3*N
C                   iterations, with the accuracy required in the
C                   call;
C             = 3:  the cosine of the angle between e and any column of
C                   the Jacobian is at most FACTOR*EPS in absolute
C                   value, where FACTOR = 100 is defined in a PARAMETER
C                   statement;
C             = 4:  TOL is too small: no further reduction in the sum
C                   of squares is possible.
C                   In all these cases, DWORK(1:5) are set as described
C                   above.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  user-defined routine FCN returned with INFO <> 0
C                   for IFLAG = 1;
C             = 2:  user-defined routine FCN returned with INFO <> 0
C                   for IFLAG = 2;
C             = 3:  SLICOT Library routine MB02XD, if ALG = 'D', or
C                   SLICOT Library routine MB02WD, if ALG = 'I' (or
C                   user-defined routine JPJ), returned with INFO <> 0.
C
C     METHOD
C
C     If XINIT = 'R', the initial value for X is set to a vector of
C     pseudo-random values uniformly distributed in [-1,1].
C
C     The Levenberg-Marquardt algorithm (described in [1]) is used for
C     optimizing the parameters. This algorithm needs the Jacobian
C     matrix J, which is provided by the subroutine FCN. The algorithm
C     tries to update x by the formula
C
C         x = x - p,
C
C     using the solution of the system of linear equations
C
C         (J'*J + PAR*I)*p = J'*e,
C
C     where I is the identity matrix, and e the error function vector.
C     The Levenberg factor PAR is decreased after each successfull step
C     and increased in the other case.
C
C     If ALG = 'D', a direct method, which evaluates the matrix product
C     J'*J + par*I and then factors it using Cholesky algorithm,
C     implemented in the SLICOT Libray routine MB02XD, is used for
C     solving the linear system above.
C
C     If ALG = 'I', the Conjugate Gradients method, described in [2],
C     and implemented in the SLICOT Libray routine MB02WD, is used for
C     solving the linear system above. The main advantage of this method
C     is that in most cases the solution of the system can be computed
C     in less time than the time needed to compute the matrix J'*J
C     This is, however, problem dependent.
C
C     REFERENCES
C
C     [1] Kelley, C.T.
C         Iterative Methods for Optimization.
C         Society for Industrial and Applied Mathematics (SIAM),
C         Philadelphia (Pa.), 1999.
C
C     [2] Golub, G.H. and van Loan, C.F.
C         Matrix Computations. Third Edition.
C         M. D. Johns Hopkins University Press, Baltimore, pp. 520-528,
C         1996.
C
C     [3] More, J.J.
C         The Levenberg-Marquardt algorithm: implementation and theory.
C         In Watson, G.A. (Ed.), Numerical Analysis, Lecture Notes in
C         Mathematics, vol. 630, Springer-Verlag, Berlin, Heidelberg
C         and New York, pp. 105-116, 1978.
C
C     NUMERICAL ASPECTS
C
C     The Levenberg-Marquardt algorithm described in [3] is scaling
C     invariant and globally convergent to (maybe local) minima.
C     According to [1], the convergence rate near a local minimum is
C     quadratic, if the Jacobian is computed analytically, and linear,
C     if the Jacobian is computed numerically.
C
C     Whether or not the direct algorithm is faster than the iterative
C     Conjugate Gradients algorithm for solving the linear systems
C     involved depends on several factors, including the conditioning
C     of the Jacobian matrix, and the ratio between its dimensions.
C
C     CONTRIBUTORS
C
C     A. Riedel, R. Schneider, Chemnitz University of Technology,
C     Oct. 2000.
C     V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001,
C     Mar. 2002.
C
C     KEYWORDS
C
C     Conjugate gradients, least-squares approximation,
C     Levenberg-Marquardt algorithm, matrix operations, optimization.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, FIVE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, FIVE = 5.0D0 )
      DOUBLE PRECISION  FACTOR, MARQF, MINIMP, PARMAX
      PARAMETER         ( FACTOR = 10.0D0**2,    MARQF  = 2.0D0**2,
     $                    MINIMP =  2.0D0**(-3), PARMAX = 1.0D20 )
C     .. Scalar Arguments ..
      CHARACTER         ALG, STOR, UPLO, XINIT
      INTEGER           INFO, ITMAX, IWARN, LDPAR1, LDPAR2, LDWORK,
     $                  LIPAR, M, N, NFEV, NJEV, NPRINT
      DOUBLE PRECISION  CGTOL, TOL
C     .. Array Arguments ..
      DOUBLE PRECISION  DPAR1(LDPAR1,*), DPAR2(LDPAR2,*), DWORK(*), X(*)
      INTEGER           IPAR(*)
C     .. Local Scalars ..
      LOGICAL           CHOL, FULL, INIT, UPPER
      INTEGER           DWJTJ, E, I, IFLAG, INFOL, ITER, ITERCG, IW1,
     $                  IW2, IWARNL, JAC, JTE, JW1, JW2, JWORK, LDJ,
     $                  LDW, LFCN1, LFCN2, LJTJ, LJTJD, LJTJI, NFEVL,
     $                  SIZEJ, WRKOPT
      DOUBLE PRECISION  ACTRED, BIGNUM, CGTDEF, EPSMCH, FNORM, FNORM1,
     $                  GNORM, GSMIN, PAR, SMLNUM, SQREPS, TOLDEF
C     .. Local Arrays ..
      INTEGER           SEED(4)
C     .. External Functions ..
      DOUBLE PRECISION  DDOT, DLAMCH, DNRM2
      LOGICAL           LSAME
      EXTERNAL          DDOT, DLAMCH, DNRM2, LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DLABAD, DLARNV, FCN, JPJ, MB02WD, MB02XD,
     $                  XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX, MIN, MOD, SQRT
C     ..
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      INIT  = LSAME( XINIT, 'R' )
      CHOL  = LSAME( ALG,   'D' )
      FULL  = LSAME( STOR,  'F' )
      UPPER = LSAME( UPLO,  'U' )
C
C     Check the scalar input parameters.
C
      IWARN = 0
      INFO  = 0
      IF( .NOT.( INIT .OR. LSAME( XINIT, 'G' ) ) ) THEN
         INFO = -1
      ELSEIF ( .NOT.( CHOL .OR. LSAME( ALG, 'I' ) ) ) THEN
         INFO = -2
      ELSEIF ( CHOL .AND. .NOT.( FULL  .OR. LSAME( STOR, 'P' ) ) ) THEN
         INFO = -3
      ELSEIF ( CHOL .AND. .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
         INFO = -4
      ELSEIF ( M.LT.0 ) THEN
         INFO = -7
      ELSEIF ( N.LT.0 .OR. N.GT.M ) THEN
         INFO = -8
      ELSEIF ( ITMAX.LT.0 ) THEN
         INFO = -9
      ELSEIF ( LIPAR.LT.5 ) THEN
         INFO = -12
      ELSEIF( LDPAR1.LT.0 ) THEN
         INFO = -14
      ELSEIF( LDPAR2.LT.0 ) THEN
         INFO = -16
      ELSEIF ( LDWORK.LT.5 ) THEN
         INFO = -23
      ENDIF
C
C     Return if there are illegal arguments.
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MD03AD', -INFO )
         RETURN
      ENDIF
C
C     Quick return if possible.
C
      NFEV = 0
      NJEV = 0
      IF ( MIN( N, ITMAX ).EQ.0 ) THEN
         DWORK(1) = FIVE
         DWORK(2) = ZERO
         DWORK(3) = ZERO
         DWORK(4) = ZERO
         DWORK(5) = ZERO
         RETURN
      ENDIF
C
C     Call FCN to get the size of the array J, for storing the Jacobian
C     matrix, the leading dimension LDJ and the workspace required
C     by FCN for IFLAG = 1 and IFLAG = 2, and JPJ. The entries
C     DWORK(1:4) should not be modified by the special call of FCN
C     below, if XINIT = 'R' and the values in DWORK(1:4) are explicitly
C     desired for initialization of the random number generator.
C
      IFLAG = 3
      IW1   = IPAR(1)
      IW2   = IPAR(2)
      JW1   = IPAR(3)
      JW2   = IPAR(4)
      LJTJ  = IPAR(5)
C
      CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, LDPAR2,
     $          X, NFEVL, DWORK, DWORK, LDJ, DWORK, DWORK, LDWORK,
     $          INFOL )
C
      SIZEJ = IPAR(1)
      LFCN1 = IPAR(2)
      LFCN2 = IPAR(3)
      LJTJD = IPAR(4)
      LJTJI = IPAR(5)
C
      IPAR(1) = IW1
      IPAR(2) = IW2
      IPAR(3) = JW1
      IPAR(4) = JW2
      IPAR(5) = LJTJ
C
C     Define pointers to the array variables stored in DWORK.
C
      JAC = 1
      E   = JAC + SIZEJ
      JTE = E   + M
      IW1 = JTE + N
      IW2 = IW1 + N
      JW1 = IW2
      JW2 = IW2 + N
C
C     Check the workspace length.
C
      JWORK = JW1
      IF ( CHOL ) THEN
         IF ( FULL ) THEN
            LDW = N*N
         ELSE
            LDW = ( N*( N + 1 ) ) / 2
         ENDIF
         DWJTJ = JWORK
         JWORK = DWJTJ + LDW
         LJTJ  = LJTJD
      ELSE
         LDW  = 3*N
         LJTJ = LJTJI
      ENDIF
      IF ( LDWORK.LT.MAX( 5, SIZEJ + M + 2*N +
     $                       MAX( LFCN1 + N, LFCN2, LDW + LJTJ ) ) )
     $      THEN
         INFO = -23
      ENDIF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MD03AD', -INFO )
         RETURN
      ENDIF
C
C     Set default tolerances. SQREPS is the square root of the machine
C     precision, and GSMIN is used in the tests of the gradient norm.
C
      EPSMCH = DLAMCH( 'Epsilon' )
      SQREPS = SQRT( EPSMCH )
      TOLDEF = TOL
      IF ( TOLDEF.LT.ZERO )
     $   TOLDEF = SQREPS
      CGTDEF = CGTOL
      IF ( CGTDEF.LE.ZERO )
     $   CGTDEF = SQREPS
      GSMIN  = FACTOR*EPSMCH
      WRKOPT = 5
C
      SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
C
C     Initialization.
C
      IF ( INIT ) THEN
C
C        SEED is the initial state of the random number generator.
C        SEED(4) must be odd.
C
         SEED(1) = MOD(   INT( DWORK(1) ), 4096 )
         SEED(2) = MOD(   INT( DWORK(2) ), 4096 )
         SEED(3) = MOD(   INT( DWORK(3) ), 4096 )
         SEED(4) = MOD( 2*INT( DWORK(4) ) + 1, 4096 )
         CALL DLARNV( 2, SEED, N, X )
      ENDIF
C
C     Evaluate the function at the starting point and calculate
C     its norm.
C     Workspace: need:    SIZEJ + M + 2*N + LFCN1;
C                prefer:  larger.
C
      IFLAG = 1
      CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, LDPAR2,
     $          X, NFEVL, DWORK(E), DWORK(JAC), LDJ, DWORK(JTE),
     $          DWORK(JW1), LDWORK-JW1+1, INFOL )
C
      IF ( INFOL.NE.0 ) THEN
         INFO = 1
         RETURN
      END IF
      WRKOPT = MAX( WRKOPT, INT( DWORK(JW1) ) + JW1 - 1 )
      NFEV   = 1
      FNORM  = DNRM2( M, DWORK(E), 1 )
      ACTRED = ZERO
      ITERCG = 0
      ITER   = 0
      IWARNL = 0
      PAR    = ZERO
      IF ( IFLAG.LT.0 .OR. FNORM.EQ.ZERO )
     $   GO TO 40
C
C     Set the initial vector for the conjugate gradients algorithm.
C
      DWORK(IW1) = ZERO
      CALL DCOPY( N, DWORK(IW1), 0, DWORK(IW1), 1 )
C
C     WHILE ( nonconvergence and ITER < ITMAX ) DO
C
C     Beginning of the outer loop.
C
   10 CONTINUE
C
C        Calculate the Jacobian matrix.
C        Workspace: need:    SIZEJ + M + 2*N + LFCN2;
C                   prefer:  larger.
C
         ITER  = ITER + 1
         IFLAG = 2
         CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2,
     $             LDPAR2, X, NFEVL, DWORK(E), DWORK(JAC), LDJ,
     $             DWORK(JTE), DWORK(JW1), LDWORK-JW1+1, INFOL )
C
         IF ( INFOL.NE.0 ) THEN
            INFO = 2
            RETURN
         END IF
C
C        Compute the gradient norm.
C
         GNORM = DNRM2( N, DWORK(JTE), 1 )
         IF ( NFEVL.GT.0 )
     $      NFEV = NFEV + NFEVL
         NJEV = NJEV + 1
         IF ( GNORM.LE.GSMIN )
     $      IWARN = 3
         IF ( IWARN.NE.0 )
     $      GO TO 40
         IF ( ITER.EQ.1 ) THEN
            WRKOPT = MAX( WRKOPT, INT( DWORK(JW1) ) + JW1 - 1 )
            PAR    = MIN( GNORM, SQRT( PARMAX ) )
         END IF
         IF ( IFLAG.LT.0 )
     $      GO TO 40
C
C        If requested, call FCN to enable printing of iterates.
C
         IF ( NPRINT.GT.0 ) THEN
            IFLAG = 0
            IF ( MOD( ITER-1, NPRINT ).EQ.0 ) THEN
               CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2,
     $                   LDPAR2, X, NFEV, DWORK(E), DWORK(JAC), LDJ,
     $                   DWORK(JTE), DWORK(JW1), LDWORK-JW1+1, INFOL )
C
               IF ( IFLAG.LT.0 )
     $            GO TO 40
            END IF
         END IF
C
C        Beginning of the inner loop.
C
   20    CONTINUE
C
C           Store the Levenberg factor in DWORK(E) (which is no longer
C           needed), to pass it to JPJ routine.
C
            DWORK(E) = PAR
C
C           Solve (J'*J + PAR*I)*x = J'*e, and store x in DWORK(IW1).
C           Additional workspace:
C                      N*N + DW(JPJ),          if ALG = 'D', STOR = 'F';
C                      N*( N + 1)/2 + DW(JPJ), if ALG = 'D', STOR = 'P';
C                      3*N + DW(JPJ),          if ALG = 'I'.
C
            IF ( CHOL ) THEN
               CALL DCOPY( N, DWORK(JTE), 1, DWORK(IW1), 1 )
               CALL MB02XD( 'Function', STOR, UPLO, JPJ, M, N, 1, IPAR,
     $                      LIPAR, DWORK(E), 1, DWORK(JAC), LDJ,
     $                      DWORK(IW1), N, DWORK(DWJTJ), N,
     $                      DWORK(JWORK), LDWORK-JWORK+1, INFOL )
            ELSE
               CALL MB02WD( 'Function', JPJ, N, IPAR, LIPAR, DWORK(E),
     $                      1, 3*N, DWORK(JAC), LDJ, DWORK(JTE), 1,
     $                      DWORK(IW1), 1, CGTOL*GNORM, DWORK(JWORK),
     $                      LDWORK-JWORK+1, IWARN, INFOL )
               ITERCG = ITERCG + INT( DWORK(JWORK) )
               IWARNL = MAX( 2*IWARN, IWARNL )
            ENDIF
C
            IF ( INFOL.NE.0 ) THEN
               INFO = 3
               RETURN
            ENDIF
C
C           Compute updated X.
C
            DO 30 I = 0, N - 1
               DWORK(IW2+I) = X(I+1) - DWORK(IW1+I)
   30       CONTINUE
C
C           Evaluate the function at x - p and calculate its norm.
C           Workspace:  need:    SIZEJ + M + 3*N + LFCN1;
C                       prefer:  larger.
C
            IFLAG = 1
            CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2,
     $                LDPAR2, DWORK(IW2), NFEVL, DWORK(E), DWORK(JAC),
     $                LDJ, DWORK(JTE), DWORK(JW2), LDWORK-JW2+1, INFOL )
C
            IF ( INFOL.NE.0 ) THEN
               INFO = 1
               RETURN
            END IF
C
            NFEV = NFEV + 1
            IF ( IFLAG.LT.0 )
     $         GO TO 40
            FNORM1 = DNRM2( M, DWORK(E), 1 )
C
C           Now, check whether this step was successful and update the
C           Levenberg factor.
C
            IF ( FNORM.LT.FNORM1 ) THEN
C
C              Unsuccessful step: increase PAR.
C
               ACTRED = ONE
               IF ( PAR.GT.PARMAX ) THEN
                  IF ( PAR/MARQF.LE.BIGNUM )
     $               PAR = PAR*MARQF
               ELSE
                  PAR = PAR*MARQF
               END IF
C
            ELSE
C
C              Successful step: update PAR, X, and FNORM.
C
               ACTRED = ONE - ( FNORM1/FNORM )**2
               IF ( ( FNORM - FNORM1 )*( FNORM + FNORM1 ) .LT.
     $              MINIMP*DDOT( N, DWORK(IW1), 1,
     $                           DWORK(JTE), 1 ) ) THEN
                  IF ( PAR.GT.PARMAX ) THEN
                     IF ( PAR/MARQF.LE.BIGNUM )
     $                  PAR = PAR*MARQF
                  ELSE
                     PAR = PAR*MARQF
                  END IF
               ELSE
                  PAR = MAX( PAR/MARQF, SMLNUM )
               ENDIF
               CALL DCOPY( N, DWORK(IW2), 1, X, 1 )
               FNORM = FNORM1
            ENDIF
C
            IF ( ( ACTRED.LE.TOLDEF ) .OR. ( ITER.GT.ITMAX ) .OR.
     $           ( PAR.GT.PARMAX ) )
     $         GO TO 40
            IF ( ACTRED.LE.EPSMCH ) THEN
               IWARN = 4
               GO TO 40
            ENDIF
C
C           End of the inner loop. Repeat if unsuccessful iteration.
C
            IF ( FNORM.LT.FNORM1 )
     $         GO TO 20
C
C        End of the outer loop.
C
         GO TO 10
C
C     END WHILE 10
C
   40 CONTINUE
C
C     Termination, either normal or user imposed.
C
      IF ( ACTRED.GT.TOLDEF )
     $   IWARN = 1
      IF ( IWARNL.NE.0 )
     $   IWARN = 2
C
      IF ( IFLAG.LT.0 )
     $   IWARN = IFLAG
      IF ( NPRINT.GT.0 ) THEN
         IFLAG = 0
         CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2,
     $             LDPAR2, X, NFEV, DWORK(E), DWORK(JAC), LDJ,
     $             DWORK(JTE), DWORK(JW1), LDWORK-JW1+1, INFOL )
         IF ( IFLAG.LT.0 )
     $      IWARN = IFLAG
      END IF
C
      DWORK(1) = WRKOPT
      DWORK(2) = FNORM
      DWORK(3) = ITER
      DWORK(4) = ITERCG
      DWORK(5) = PAR
C
      RETURN
C *** Last line of MD03AD ***
      END


program hickerson
    implicit none
    integer, parameter :: q = selected_real_kind(30)
    integer, parameter :: l = selected_int_kind(15)
    real(q) :: s, l2
    integer :: i, n, k

    l2 = log(2.0_q)
    do n = 1, 17
        s = 0.5_q / l2
        do i = 1, n
            s = (s * i) / l2
        end do

        k = floor((s - floor(s, l)) * 10)
        if (k == 0 .or. k == 9) then
            print 1, n, s, ""
        else
            print 1, n, s, " NOT"
        endif
    end do
  1 format('h(',I2,') = ',F23.3,' is',A,' an almost-integer')
end program


c=======================================================================
c
c     subroutine ALLOCITRFR
c
c     Index Tracking allocation srtategy with a risk-free asset
c
c     w(i), i=1,...,n the riskly assets (portfolio weights)
c     w(0), the risk-free asset
c
c     Min[ Tracking Error ]
c      s.t.
c     (rho*w+rfr*w(0) - index perf. >= delta (relative target return)
c     C*w <= b                               (linear constraints)
c     Cinf(i) <= w(i) <= Csup(i)             (riskly assets lower/upper bounds)
c     Cinf(0) <= w(0) <= Csup(0)             (risk-free asset lower/upper bounds)
c
c        Q   : covariance matrix
c        rho : expected returns
c        rfr : risk-free rate
c
c----------------------------------------------------------------------
      SUBROUTINE allocitrfr ( n, cov, rho, covb, rhob, rfr,
     &                        neq, nin, ccst, bcst, cinf, csup,
     &                        cinfrfr, csuprfr, delta,
     &                        iwork, dwork, wopt, wrf, info )
c-----------------------------------------------------------------------
c
c     INPUT
c       n       : portfolio size                                 integer
c       cov     : covariance matrix (n*n)                         double
c       rho     : expected mean returns (n)                       double
c       covb    : covariance assets-index (n)                     double
c       rhob    : expected mean return of index                   double
c       rfr     : expected risk-free rate                         double
c       neq     : number of equality constraints                 integer
c       nin     : number of inequality constraints               integer
c       ccst    : matrix of constraints (n*(neq+nin))             double
c       bcst    : vector of constraints (neq+nin)                 double
c       cinf    : lower bound (n)                                 double
c       csup    : upper bound (n)                                 double
c       cinfrfr : risk-free lower bound                           double
c       csuprfr : risk-free upper bound                           double
c       delta   : relative target return                          double
c
c     WORKSPACE
c       iwork   : 3*n + 2*nin + neq + 7                          integer
c       dwork   : n*(2*neq+2*nin+2*n+23)+6*nin+4*neq+31           double
c
c     OUTPUT
c       wopt    : optimal portfolio (n)                           double
c       wrf     : optimal risk-free asset                         double
c       info    : diagnostic argument                            integer
c
c     CALL
c       OPIT    : computing optimization for ALLOCIT (cf. OPIT.F)
c       TESTSDP : test if covariance matrix is SDP
c       SEV     : vector sum
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, info, neq, nin
      DOUBLE PRECISION rhob, delta, rfr, cinfrfr, csuprfr, wrf
      DOUBLE PRECISION cov(*), rho(*), covb(*), cinf(*), csup(*),
     &                 wopt(*), ccst(n,*), bcst(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER pisdp, piwo, pdsdp, pdwo, pdlagr
      DOUBLE PRECISION sum
c
c     external subroutines
      EXTERNAL testsdp, opitrfr, SEV
c
c-----------------------------------------------------------------------
c
c     initialization
      info = 0          ! diagnostic argument
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      pisdp = 1
c     pisdp : pointer for workspace of TESTSDP (n)
      piwo  = 1
c     piwo  : pointer for OPITRFR (3*n + 2*nin + neq + 7)
c
c     Total size of iwork array = 3*n + 2*nin + neq + 7
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdsdp = 1
c     pdsdp : pointer for TESTSDP (n*(2*n + 7))
      pdlagr = 1
c     pdlagr : pointer for lagrange multipliers (n + neq + nin + 3)
      pdwo  = pdlagr + ( n + neq + nin + 3 )
c     pdwo  : pointer for OPITRFR
c               n*(2*n+2*nin+2*neq+22)+3*neq+5*nin+28
c
c     Total size of dwork array = n*(2*neq+2*nin+2*n+23)+6*nin+4*neq+31
c
c--------------------------------------------------------------------
c
c     covariance matrix SDP ?
      CALL testsdp (n, cov, iwork(pisdp), dwork(pdsdp), info)
      IF (info .NE. 0) THEN
         info = -108
         RETURN
      ENDIF
c
c     optimization - traking error minimization (with risk-free asset)
      CALL opitrfr ( n, cov, covb, rho, rhob, rfr, delta,
     &               neq, nin, ccst, bcst,
     &               cinf, csup, cinfrfr, csuprfr,
     &               iwork(piwo), dwork(pdwo), wopt, dwork(pdlagr),
     &               info )
      IF (info .EQ. 1001) THEN
        info = -101
      ENDIF
c
c     risk-free asset weight
      CALL SEV ( n, wopt, sum )
      wrf = 1.0 - sum
      RETURN
      END