cnmn01 Subroutine

private subroutine cnmn01(me, jgoto, x, df, g, isc, ic, a, g1, vub, scal, ncal, dx, dx1, fi, xi, iii, n1, n2, n3)

Routine to calculate gradient information by finite difference.

BY G. N. VANDERPLAATS, JUNE, 1972.

Type Bound

conmin_class

Arguments

Type IntentOptional Attributes Name
class(conmin_class), intent(inout) :: me
integer, intent(inout) :: jgoto
real(kind=wp), intent(inout) :: x(:)
real(kind=wp), intent(inout) :: df(:)
real(kind=wp), intent(inout) :: g(n2)
integer, intent(in) :: isc(n2)
integer, intent(inout) :: ic(n3)
real(kind=wp), intent(inout) :: a(n1,n3)
real(kind=wp), intent(inout) :: g1(n2)
real(kind=wp), intent(in) :: vub(:)
real(kind=wp), intent(in) :: scal(:)
integer, intent(inout) :: ncal(2)
real(kind=wp), intent(out) :: dx
real(kind=wp), intent(out) :: dx1
real(kind=wp), intent(out) :: fi
real(kind=wp), intent(out) :: xi
integer, intent(out) :: iii
integer, intent(in) :: n1
integer, intent(in) :: n2
integer, intent(in) :: n3

Called by

proc~~cnmn01~~CalledByGraph proc~cnmn01 conmin_class%cnmn01 proc~conmin conmin_class%conmin proc~conmin->proc~cnmn01

Source Code

    subroutine cnmn01(me, jgoto, x, df, g, isc, ic, a, g1, vub, scal, ncal, dx, &
                      dx1, fi, xi, iii, n1, n2, n3)

        !!  Routine to calculate gradient information by finite difference.
        !!
        !!  BY G. N. VANDERPLAATS, JUNE, 1972.

        class(conmin_class), intent(inout) :: me
        integer, intent(inout)    :: jgoto
        real(wp), intent(in)      :: vub(:), scal(:)
        integer, intent(in)       :: n1, n2, n3
        real(wp), intent(inout)   :: x(:), df(:), g(n2), a(n1, n3), g1(n2)
        integer, intent(inout)    :: ic(n3), ncal(2)
        integer, intent(in)       :: isc(n2)
        real(wp), intent(out)     :: dx, dx1, fi, xi
        integer, intent(out)      :: iii

        real(wp)  :: fdch1, x1
        integer   :: i, i1, inf, j

        if (jgoto /= 1) then
            if (jgoto == 2) go to 40
            me%infog = 0
            inf = me%info
            me%nac = 0
            if (me%linobj == 0 .or. me%iter <= 1) then
                ! ------------------------------------------------------------------
                !                GRADIENT OF LINEAR OBJECTIVE
                ! ------------------------------------------------------------------
                if (me%nfdg == 2) jgoto = 1
                if (me%nfdg == 2) return
            end if
        end if
        jgoto = 0
        if (me%nfdg == 2 .and. me%ncon == 0) return
        if (me%ncon /= 0) then
            ! ------------------------------------------------------------------
            !   * * * DETERMINE WHICH CONSTRAINTS ARE ACTIVE OR VIOLATED * * *
            ! ------------------------------------------------------------------
            do i = 1, me%ncon
                if (g(i) >= me%ct) then
                    if (isc(i) <= 0 .or. g(i) >= me%ctl) then
                        me%nac = me%nac + 1
                        if (me%nac >= n3) return
                        ic(me%nac) = i
                    end if
                end if
            end do
            if (me%nfdg == 2 .and. me%nac == 0) return
            if (me%linobj > 0 .and. me%iter > 1 .and. me%nac == 0) return
            ! ------------------------------------------------------------------
            !              STORE VALUES OF CONSTRAINTS IN G1
            ! ------------------------------------------------------------------
            g1(1:me%ncon) = g(1:me%ncon)
        end if
        jgoto = 0
        if (me%nac == 0 .and. me%nfdg == 2) return
        ! ------------------------------------------------------------------
        !                        CALCULATE GRADIENTS
        ! ------------------------------------------------------------------
        me%infog = 1
        me%info = 1
        fi = me%obj
        iii = 0

30      iii = iii + 1
        xi = x(iii)
        dx = me%fdch*xi
        dx = abs(dx)
        fdch1 = me%fdchm
        if (me%nscal /= 0) fdch1 = me%fdchm/scal(iii)
        if (dx < fdch1) dx = fdch1
        x1 = xi + dx
        if (me%nside /= 0) then
            if (x1 > vub(iii)) dx = -dx
        end if
        dx1 = 1.0_wp/dx
        x(iii) = xi + dx
        ncal(1) = ncal(1) + 1
        !  ------------------------------------------------------------------
        !                      FUNCTION EVALUATION
        !  ------------------------------------------------------------------
        jgoto = 2
        return

40      x(iii) = xi
        if (me%nfdg == 0) df(iii) = dx1*(me%obj - fi)
        if (me%nac /= 0) then
            ! ------------------------------------------------------------------
            !         DETERMINE GRADIENT COMPONENTS OF ACTIVE CONSTRAINTS
            ! ------------------------------------------------------------------
            do j = 1, me%nac
                i1 = ic(j)
                a(iii, j) = dx1*(g(i1) - g1(i1))
            end do
        end if
        if (iii < me%ndv) go to 30
        me%infog = 0
        me%info = inf
        jgoto = 0
        me%obj = fi
        if (me%ncon == 0) return
        ! ------------------------------------------------------------------
        !         STORE CURRENT CONSTRAINT VALUES BACK IN G-VECTOR
        ! ------------------------------------------------------------------
        g(1:me%ncon) = g1(1:me%ncon)

    end subroutine cnmn01