!************************************************************************* !* * !* Computation of the value of the NN regression problem and the * !* the corresbonding subgradients. Called from the subroutine lmbm. * !* (last modified 30.09.2020). * !* * !* This file is specially modified to solve NNR problems. * !* * !************************************************************************* !* !* Modules included: !* !* obj_fun ! !* MODULE objfun ! Computation of the value and the subgradient of the ! objective function. USE r_precision, ONLY : prec ! Precision for reals. IMPLICIT NONE PUBLIC :: & myf, & ! Computation of the value of the objective. myg ! Computation of the subgradient of the objective. CONTAINS !************************************************************************ !* * !* * SUBROUTINE myf * * !* * !* Computation of the value of the NNR-objective at x. * !* * !************************************************************************ SUBROUTINE myf(n,x,f,iterm) USE param, ONLY : zero,large ! Parameters. USE initnn, ONLY : & mX, & ! Input matrix. mY, & ! Output vector. nft, & ! Number of input features. ntrain, & ! Size of the training set. nH, & ! Current number of hidden nodes. rho ! Penalization parameter. IMPLICIT NONE ! Array Arguments REAL(KIND=prec), DIMENSION(n), INTENT(IN) :: & x ! Vector of variables. ! w_1BP <---> x(1) ! w_0kj <---> x(1+(j-1)*(nft+2)+k) ! w_0Bj <---> x(1+(j-1)*(nft+2)+nft+1) ! w_1jP <---> x(1+j*(nft+2)) (i.e. x(1+(j-1)*(nft+2)+nft+2) ) ! Scalar Arguments REAL(KIND=prec), INTENT(OUT) :: f ! Value of the function. INTEGER, INTENT(IN) :: n ! Number of variables = nH*(nft+2)+1. INTEGER, INTENT(OUT) :: iterm ! Cause of termination: ! 0 - Everything is ok. ! -3 - Failure in function calculations. ! Local scalars REAL(KIND=prec) :: s_ij, p_i, dev, f_pen INTEGER :: i_w1jP, i_w0Bj, i_w0kj ! Indices for weights. INTEGER :: i,j,k iterm = 0 !************************************************************ ! The Problem with L1-norm !************************************************************ f = zero DO i = 1, ntrain ! Each data point in the training set is looked through p_i = x(1) ! w_1BP is initialized as the value of p_i DO j = 1, nH ! Each hidden node is looked through i_w1jP = 1 + j*(nft+2) ! Index for w_1jP i_w0Bj = 1 + j*(nft+2) - 1 ! Index for w_0Bj s_ij = x(i_w0Bj) ! w_0Bj i_w0kj = 1 + (j-1)*(nft+2) ! Initialization of index for w_0kj DO k = 1, nft ! Inputs of data point i are looked through i_w0kj = i_w0kj + 1 ! Index for w_0kj s_ij = s_ij + x(i_w0kj)*mX(k,i) ! Update of s_ij ! tarkista miten päin tämä matriisi on ja miten päin sitä kannattaa lukea END DO ! Ensimmäisen indeksi tulee muuttua nopeimmin, eli tämä olisi oikein näin. ! nyt kuitenkin se vastaisi a(nft,nrecord), saatko fiksusti luettua sen näin päin? IF (s_ij >= zero) THEN p_i = p_i + x(i_w1jP)*s_ij END IF END DO dev = mY(i)-p_i IF (dev >= zero) THEN f = f + dev ELSE f = f - dev END IF END DO ! L1 penalization, we want all weights as small as possible? f_pen = zero DO i = 1, n f_pen = f_pen + ABS(x(i)) END DO f = f + rho*f_pen ! Error checking. IF (f > large) iterm = -3 ! IF (f < -large) iterm = -3 ! RETURN END SUBROUTINE myf !************************************************************************ !* * !* * SUBROUTINE myg * * !* * !* Computation of the subgradient of the NNR function. * !* * !************************************************************************ SUBROUTINE myg(n,x,g,iterm) USE param, ONLY : zero,one,large ! Parameters. USE initnn, ONLY : & mX, & ! Input matrix. mY, & ! Output vector. nft, & ! Number of input features. !ns, & ! Switch for auxiliary and real clustering problem. ntrain, & ! Size of the training set. nH, & ! Current number of hidden nodes. rho ! Penalization parameter. Default = 1.0. IMPLICIT NONE ! Array Arguments REAL(KIND=prec), DIMENSION(n), INTENT(IN) :: & x ! Vector of variables. ! w_1BP <---> x(1) ! w_0kj <---> x(1+(j-1)*(nft+2)+k) ! w_0Bj <---> x(1+(j-1)*(nft+2)+nft+1) ! w_1jP <---> x(1+j*(nft+2)) (i.e. x(1+(j-1)*(nft+2)+nft+2) ) REAL(KIND=prec), DIMENSION(n), INTENT(OUT) :: & g ! Subgradient. ! Scalar Arguments INTEGER, INTENT(IN) :: n ! Number of variables. INTEGER, INTENT(OUT) :: iterm ! Cause of termination: ! 0 - Everything is ok. ! -3 - Failure in subgradient calculations. ! Local REAL(KIND=prec), DIMENSION(n) :: g_i REAL(KIND=prec) :: s_ij, p_i, dev INTEGER :: i_w1jP, i_w0Bj, i_w0kj ! Indices for weights. INTEGER :: i,j,k iterm = 0 ! Gradient evaluation. g = zero DO i = 1, ntrain ! Each data point in the training set is looked through g_i = zero p_i = x(1) ! w_1BP is initialized as the value of p_i DO j = 1, nH ! Each hidden node is looked through i_w1jP = 1 + j*(nft+2) ! Index for w_1jP i_w0Bj = 1 + j*(nft+2) - 1 ! Index for w_0Bj s_ij = x(i_w0Bj) ! w_0Bj i_w0kj = 1 + (j-1)*(nft+2) DO k = 1, nft ! Inputs of data point i are looked through i_w0kj = i_w0kj + 1 ! Index for w_0kj s_ij = s_ij + x(i_w0kj)*mX(k,i) ! Update of s_ij END DO IF (s_ij >= zero) THEN p_i = p_i + x(i_w1jP)*s_ij ! Update of p_i i_w0kj = 1 + (j-1)*(nft+2) DO k = 1,nft i_w0kj = i_w0kj + 1 g_i(i_w0kj) = g_i(i_w0kj) + mX(k,i)*x(i_w1jP) END DO i_w0kj = i_w0kj + 1 g_i(i_w0kj) = g_i(i_w0kj) + x(i_w1jP) g_i(i_w1jP) = g_i(i_w1jP) + s_ij END IF END DO g_i(1) = g_i(1) + one dev = mY(i)-p_i IF (dev >= zero) THEN g_i = (-one) * g_i END IF g = g + g_i END DO g_i=zero DO i = 1, n IF (x(i)>=zero) THEN g_i(i) = g_i(i) + one ELSE g_i(i) = g_i(i) - one END IF END DO g = g + rho * g_i RETURN END SUBROUTINE myg END MODULE objfun