ogexec Subroutine

private subroutine ogexec(me, Valvar, Valcon, Finopt, Finite)

Main routine.

2008/01/16 | J. SCHOENMAEKERS | NEW

Type Bound

optgra

Arguments

Type IntentOptional Attributes Name
class(optgra), intent(inout) :: me
real(kind=wp), intent(inout) :: Valvar(me%Numvar)

VARIABLES VALUE -> NOT SCALED
real(kind=wp), intent(out) :: Valcon(me%Numcon+1)

CONSTRAINTS VALUE (1:NUMCON) MERIT VALUE (1+NUMCON) -> NOT SCALED
integer(kind=ip), intent(out) :: Finopt

TERMINATION STATUS

  • 1 = MATCHED & OPTIMAL
  • 2 = MATCHED & NOT OPTIMAL
  • 3 = NOT MATCHED & NOT OPTIMAL
  • 4 = NOT FEASIBL & NOT OPTIMAL
  • -1 = Fatal error (constraints singular)
integer(kind=ip), intent(out) :: Finite

?

Calls

proc~~ogexec~~CallsGraph proc~ogexec optgra%ogexec proc~ogcorr optgra%ogcorr proc~ogexec->proc~ogcorr proc~ogeval optgra%ogeval proc~ogexec->proc~ogeval proc~ogopti optgra%ogopti proc~ogexec->proc~ogopti proc~ogpwri_end optgra%ogpwri_end proc~ogexec->proc~ogpwri_end proc~ogwrit optgra%ogwrit proc~ogexec->proc~ogwrit proc~ogcorr->proc~ogeval proc~ogcorr->proc~ogwrit proc~ogexcl optgra%ogexcl proc~ogcorr->proc~ogexcl proc~ogincl optgra%ogincl proc~ogcorr->proc~ogincl proc~ogrigt optgra%ogrigt proc~ogcorr->proc~ogrigt proc~ogeval->proc~ogwrit proc~ogpwri optgra%ogpwri proc~ogeval->proc~ogpwri proc~ogopti->proc~ogeval proc~ogopti->proc~ogwrit proc~ogopti->proc~ogexcl proc~ogopti->proc~ogincl proc~ogleft optgra%ogleft proc~ogopti->proc~ogleft proc~ogopti->proc~ogrigt proc~ogexcl->proc~ogwrit proc~ogincl->proc~ogwrit proc~ogpwri->proc~ogpwri_end proc~ogpwri_start optgra%ogpwri_start proc~ogpwri->proc~ogpwri_start

Source Code

   subroutine ogexec(me,Valvar,Valcon,Finopt,Finite)
      !! Main routine.
      !!
      !! 2008/01/16 | J. SCHOENMAEKERS | NEW

      class(optgra),intent(inout) :: me
      real(wp),intent(inout) :: Valvar(me%Numvar) !! VARIABLES VALUE
                                                  !! -> NOT SCALED
      real(wp),intent(out) :: Valcon(me%Numcon+1) !! CONSTRAINTS VALUE (1:NUMCON)
                                                  !! MERIT       VALUE (1+NUMCON)
                                                  !! -> NOT SCALED
      integer(ip),intent(out) :: Finopt !! TERMINATION STATUS
                                        !!
                                        !!  *  1 =     MATCHED &     OPTIMAL
                                        !!  *  2 =     MATCHED & NOT OPTIMAL
                                        !!  *  3 = NOT MATCHED & NOT OPTIMAL
                                        !!  *  4 = NOT FEASIBL & NOT OPTIMAL
                                        !!  * -1 = Fatal error (constraints singular)
      integer(ip),intent(out) :: Finite !! ?

      character(len=str_len) :: str
      character(len=name_len) :: nam
      integer(ip) :: finish , itecor , iteopt, &
                     var , con , typ , len , num , numvio, &
                     itediv , itecnv
      real(wp) :: val , sca , red , der , fac , old , convio, &
                  varacc , cosnew , cosold , varsav , meamer, &
                  conerr , desnor , norerr , meaerr
      real(wp) , dimension(:) , allocatable :: varsum
      real(wp) , dimension(:) , allocatable :: varcor
      real(wp) , dimension(:) , allocatable :: concor
      real(wp) , dimension(:,:) , allocatable :: conder_tmp !! JW: created to avoid "array temporary" warning
      logical :: error

      ! initialize:
      allocate (varsum(me%Numvar))
      allocate (varcor(me%Numvar))
      allocate (concor(me%Numcon+1))
      allocate (conder_tmp(me%Numcon+1,me%Numvar))

      ! ======================================================================
      ! GENERAL
      ! ----------------------------------------------------------------------
      ! LOGLEV = 2
      call me%ogwrit(2,"")
      call me%ogwrit(2,"OPTGRA START")
      call me%ogwrit(2,"")
      Finopt = 3  ! initialize with NOT MATCHED & NOT OPTIMAL
      itecor = 0
      iteopt = 0
      meaerr = 0.0_wp
      meamer = 0.0_wp
      itediv = 0
      itecnv = 0
      !me%Conopt = 0
      concor = 0.0_wp
      varcor = 0.0_wp
      desnor = 0.0_wp
      ! ----------------------------------------------------------------------
      me%Varstp = me%Varsnd
      me%Numite = 0
      cosnew = 0.0_wp
      do var = 1 , me%Numvar
         varsum(var) = 0.0_wp
         varcor(var) = 0.0_wp
      end do
      ! ======================================================================
      ! EQUALTIY CONSTRAINTS IN ACTIVE SET
      ! ----------------------------------------------------------------------
      me%Numact = 0
      do con = 1 , me%Numcon
!        IF (CONTYP(CON) == -2) CYCLE
         nam = me%Constr(con)
         len = me%Conlen(con)
         write (str,*) "CON/PRI=" , con , me%Conpri(con) , " " , nam(1:len)
         call me%ogwrit(3,str)
         me%Conact(con) = 0
         if ( me%Consca(con)>=1.0e+09_wp ) me%Contyp(con) = -2
         if ( me%Contyp(con)==0 ) then
         elseif ( me%Contyp(con)==-2 ) then
            me%Conact(con) = -2
         end if
      end do
      me%Conact(me%Numcon+1) = -3
      me%Conact(me%Numcon+2) = -3
      ! ======================================================================
      ! SCALE VARIABLES
      ! ----------------------------------------------------------------------
      do var = 1 , me%Numvar
         me%Varval(var) = Valvar(var)/me%Varsca(var)
      end do
      ! ======================================================================
      ! HEADER FOR TABLE
      ! ----------------------------------------------------------------------
      if ( me%Tablev>=1 ) write (me%Tablun,'("ITER",1X,"OPT",1X,*(1X,I10))') (var,var=1,me%Numvar) , (con,con=1,me%Numcon)

      main: do
         inner: do
            ! ======================================================================
            ! IF (NUMITE >= 52) MATLEV = 3
            ! IF (NUMITE >= 55) MATLEV = 2
            ! ======================================================================
            ! NEW ITERATION
            ! ----------------------------------------------------------------------
            if ( me%Numite>=me%Corite .and. itecor==0 ) then  ! correction limit reached
               Finopt = 3 ! not matched and not optimal
               Finite = me%Numite ! FINITE=Number of iterations at which termination occurred
               call me%ogwrit(1,"")
               write (str,'("OPTGRA: Converged: not ITERAT=",2I4,2D11.3)') &
                        me%Numite , me%Maxite , conerr , desnor
               call me%ogwrit(1,str)

               ! Final Pygmo output
               ! TODO: can this final fitness call be avoided (just for output)?
               me%Pygfla = 3 ! pygmo flag in COMMON: no covergence
               call evaluation_func_and_der()
               exit main
            elseif ( me%Numite>=me%Maxite .or. (me%Numite-itecor>=me%Optite-1 .and. itecor/=0) ) then
               ! Maximum iteration reached or after correction phase
               Finopt = 2 ! matched, but not optimal
               Finite = iteopt
               me%Varval = varcor
               me%Conval = concor
               call me%ogwrit(1,"")
               write (str,'("OPTGRA: Converged: mat ITERAT=",2I4,2D11.3)') &
                        me%Numite , me%Maxite , conerr , desnor
               call me%ogwrit(1,str)
               call me%ogpwri_end(-Valcon(me%Numcon+1),numvio,convio)

               ! Final Pygmo output
               ! TODO: can this final fitness call be avoided (just for output)?
               me%Pygfla = 2 ! pygmo flag in COMMON: constraints matched
               call evaluation_func_and_der()
               exit main
            end if
            ! ----------------------------------------------------------------------
            me%Numite = me%Numite + 1  ! new iteration
            ! ----------------------------------------------------------------------
            call me%ogwrit(3,"")
            write (str,'("ITERAT=",I5)')me%Numite
            call me%ogwrit(2,str)
            ! ======================================================================
            ! GET VALUES AND GRADIENTS
            ! ======================================================================
            if ( me%Senopt<=0 ) then ! No sensitivity analysis, only optimisation
               call evaluation_func_and_der()
            elseif ( me%Senopt==+1 .or. me%Senopt==+3 ) then ! sens. WITH CONSTRAINT CALCULATION
               me%Varval = me%Senvar
               call me%ogeval(me%Varval,me%Conval,0,conder_tmp)
               me%Conder(1:me%Numcon+1,:) = conder_tmp
            elseif ( me%Senopt==+2 .or. me%Senopt==+4 ) then ! sens. WITH CONSTRAINT BIAS
               me%Varval = me%Senvar
               do con = 1 , me%Numcon + 1
                  sca = me%Consca(con)
                  if ( me%Contyp(con)==-1 ) sca = -sca
                  me%Conval(con) = me%Sencon(con) - me%Sendel(con)/sca
               end do
            end if
            if ( me%Senopt==-1 ) then  ! intialisation of sensitivity analysis
               me%Senvar = me%Varval
               me%Sencon = me%Conval
            end if
            ! ======================================================================
            ! Do finite-difference check of provided gradients if VARDER=-1 (documented options are 0,1,2,3)
            if ( me%Varder==-1 .and. me%Senopt<=0 ) then
               me%Conred(1:me%Numcon+1,:) = me%Conder(1:me%Numcon+1,:) ! CONDER=current constraint derivatives
               call me%ogeval(me%Varval,me%Conval,2,conder_tmp)
               me%Conder(1:me%Numcon+1,:) = conder_tmp
               write (str,'("GRADIENT CHECK")')
               call me%ogwrit(1,str)
               do var = 1 , me%Numvar
                  do con = 1 , me%Numcon + 1
                     fac = me%Varsca(var)/me%Consca(con)
                     fac = 1.0_wp
                     der = me%Conder(con,var)*fac
                     red = me%Conred(con,var)*fac
                     if ( abs(der)<1.0e-6_wp .and. abs(red)<1.0e-6_wp ) cycle
                     if ( abs(der-red)<1.0e-2_wp ) cycle
                     if ( der/=0.0_wp ) then
                        fac = red/der
                     else
                        fac = 0.0_wp
                     end if
                     if ( abs(fac-1.0_wp)<1.0e-2_wp ) cycle
                     write (str,'("VAR/CON/ANA/NUM/A2N=",2I4,3(1X,D13.6))') var , con , red , der , fac
                     call me%ogwrit(1,str)
                     nam = me%Varstr(var)
                     len = me%Varlen(var)
                     write (str,'("      VAR=",A,1X,D13.6)') nam(1:len) , me%Varval(var)*me%Varsca(var)
                     call me%ogwrit(1,str)
                     nam = me%Constr(con)
                     len = me%Conlen(con)
                     write (str,'("      CON=",A,1X,D13.6)') nam(1:len) , me%Conval(con)*me%Consca(con)
                     call me%ogwrit(1,str)
                  end do
               end do
!              CONDER(1:NUMCON+1,:) = CONRED(1:NUMCON+1,:)
!              GOTO 9999
            end if
            ! ======================================================================
            me%Sender = me%Conder  ! SENDER=derivatives for sensitivity analysis???
            do var = 1 , me%Numvar
               if ( me%Vartyp(var)/=1 ) cycle ! VARTYP=1 are sensitivity parameters, VARTYP=0 free params
!              WRITE (STR,*) "VAR=",VAR,VARVAL(VAR)*VARSCA(VAR)
!              CALL me%ogwrit (2,STR)
               me%Conder(1:me%Numcon+1,var) = 0.0_wp ! zero derivatives of free parameters???
            end do
            ! ======================================================================
            if ( me%Numite==1 ) then
               me%Vargrd = me%Varval
            else
               me%Vargrd = me%Varref
            end if
            me%Varref = me%Varval
            me%Conref = me%Conval
            ! ======================================================================
            varacc = 0.0_wp ! initialise ITERATION SCALED DISTANCE ACCUMULATED
            ! ======================================================================
            cosold = cosnew
            cosnew = me%Conval(me%Numcon+1) ! cost function value
            call me%ogwrit(3,"")
            write (str,'("OPTGRA: VALCOS=",D15.8,1X,D15.8)') cosnew , cosnew - cosold
            call me%ogwrit(3,str)
            ! ======================================================================
            ! CONSTRAINTS CORRECTION PART
            ! ----------------------------------------------------------------------
            call me%ogcorr(varacc,finish,conerr,norerr,error)
            if (error) then
               Finopt = -1
               return
            end if
            ! ----------------------------------------------------------------------
            if ( me%Tablev>=1 ) write (me%Tablun,'(I4,1X,"COR",1X,*(1X,D10.3))') &
               me%Numite , (me%Varval(var),var=1,me%Numvar) , (me%Conval(con),con=1,me%Numcon)
            ! ----------------------------------------------------------------------
            if ( me%Senopt/=0 ) then
               if ( finish/=0 ) exit inner
               Finopt = 0
               exit main
            end if
            ! ----------------------------------------------------------------------
            if ( finish==0 ) then
               me%Numact = 0
               old = meaerr
               itediv = itediv + 1
               num = min(itediv,me%Divite)
               meaerr = (meaerr*(num-1)+norerr)/num
!              WRITE (STR,*) "MEAERR=",MEAERR
!              CALL me%ogwrit (2,STR)
               if ( itediv<me%Divite .or. meaerr<=old ) cycle
               finish = -1
            end if
            ! ----------------------------------------------------------------------
            if ( finish==-1 ) then
               Finopt = 4
               Finite = me%Numite
               call me%ogwrit(1,"")
               write (str,'("OPTGRA: Converged: unf ITERAT=",2I4,2D11.3)') &
                        me%Numite , me%Maxite , conerr , desnor
               call me%ogwrit(1,str)

               ! Final Pygmo output
               ! TODO: can this final fitness call be avoided (just for output)?
               me%Pygfla = 4 ! pygmo flag in COMMON: infeasible
               call evaluation_func_and_der()
               exit main
            end if
            ! ----------------------------------------------------------------------
            itediv = 0
            iteopt = me%Numite
            if ( itecor==0 .or. concor(me%Numcon+1)<me%Conval(me%Numcon+1) ) then
               varcor = me%Varval
               concor = me%Conval
            end if
            if ( itecor==0 ) itecor = me%Numite
            ! ----------------------------------------------------------------------
            old = meamer
            itecnv = itecnv + 1
            num = min(itecnv,me%Cnvite)
            meamer = (meamer*(num-1)+concor(me%Numcon+1))/num
!           WRITE (STR,*) "MEAMER=",ITECNV,NUM,MEAMER,OLD,OLD/MEAMER
!           CALL me%ogwrit (-1,STR)
            if ( itecnv>=me%Cnvite .and. meamer<old ) then
               Finopt = 2
               Finite = iteopt
               me%Varval = varcor
               me%Conval = concor
               call me%ogwrit(1,"")
               write (str,'("OPTGRA: Converged: mat ITERAT=",2I4,2D11.3)') &
                        me%Numite , me%Maxite , conerr , desnor
               call me%ogwrit(1,str)

               ! Final Pygmo output
               ! TODO: can this final fitness call be avoided (just for output)?
               me%Pygfla = 2 ! pygmo flag in COMMON: matched
               call evaluation_func_and_der()
               exit main
            end if
            exit inner
         end do inner

         ! ======================================================================
         ! OPTIMIZATION PART
         ! ----------------------------------------------------------------------
         if ( me%Senopt<+3 ) then
            varsav = me%Varmax
            me%Varmax = me%Varmax*10.0e-1_wp
            call me%ogopti(varacc,finish,desnor,error)
            if (error) then
               Finopt = -1
               return
            end if
            me%Varmax = varsav
         end if
         ! ----------------------------------------------------------------------
         if ( me%Senopt/=0 ) then
            call me%ogwrit(1,"")
            if ( finish==0 ) then
               Finopt = 0
               call me%ogwrit(1,"OPTGRA sensitivity converged: not")
            else
               Finopt = 1
               call me%ogwrit(1,"OPTGRA sensitivity converged: yes")
            end if
            exit main
         end if
         ! ----------------------------------------------------------------------
         if ( finish==0 ) cycle main

         ! ======================================================================
         ! NOT CONVERGED
         ! ----------------------------------------------------------------------
         if ( varacc/=0.0_wp ) cycle main

         ! ======================================================================
         ! CONVERGED
         ! ----------------------------------------------------------------------
         Finopt = 1
         Finite = me%Numite
         call me%ogwrit(1,"")
         write (str,'("OPTGRA: Converged: yes ITERAT=",2I4,2D11.3)') &
                  me%Numite , me%Maxite , conerr , desnor
         call me%ogwrit(1,str)
         call me%ogwrit(3,"")

         ! Final Pygmo output
         ! TODO: can this final fitness call be avoided (just for output)?
         me%Pygfla = 1 ! covergence
         call evaluation_func_and_der()
         exit main

      end do main

!     WRITE (STR,*) "DIF=",NORM2(VARVAL-VARREF)
!     CALL me%ogwrit (1,STR)
      ! ======================================================================
      ! DESCALE VARIABLES
      ! ----------------------------------------------------------------------
!     CALL OGWMAT (3)
!     CALL me%ogeval (VARVAL, VALCON, 0, CONDER)
      do var = 1 , me%Numvar
         Valvar(var) = me%Varval(var)*me%Varsca(var)
      end do
!     IF (SENOPT /= 0) THEN
!         CALL me%ogeval (VARVAL, VALCON, 0, CONDER)
!     end if
      ! ======================================================================
      ! DESCALE VALUES
      ! ----------------------------------------------------------------------
      do con = 1 , me%Numcon + 1
         typ = me%Contyp(con)
         sca = me%Consca(con)
         if ( typ==-1 ) sca = -sca
         Valcon(con) = me%Conval(con)*sca
      end do
      ! ======================================================================
      call me%ogwrit(3,"")
      call me%ogwrit(3,"STATUS OF CONSTRAINTS:")
      call me%ogwrit(3,"")
      call me%ogwrit(3," ACT  PAS  NON COST___VAL CONSTRAINT")
      do con = 1 , me%Numcon
         if ( me%Contyp(con)==-2 ) cycle
         nam = me%Constr(con)
         len = me%Conlen(con)
         val = me%Conval(con)
         if ( me%Conact(con)>0 ) then
            write (str,'( I4,5X,6X,D10.3,1X,A)') con , val , nam(1:len)
            call me%ogwrit(3,str)
         elseif ( me%Conact(con)==0 ) then
            write (str,'( 5X,I4,6X,D10.3,1X,A)') con , val , nam(1:len)
            call me%ogwrit(3,str)
         elseif ( me%Conact(con)<0 ) then
            write (str,'(10X,I4,1X,D10.3,1X,A)') con , val , nam(1:len)
            call me%ogwrit(3,str)
         end if
      end do

      deallocate (varsum)
      deallocate (varcor)
      deallocate (concor)
      deallocate (conder_tmp)
      ! ----------------------------------------------------------------------
      call me%ogwrit(2,"")
      call me%ogwrit(2,"OPTGRA END")
      call me%ogwrit(2,"")

      contains

         subroutine evaluation_func_and_der()
            !! evaluate the function and derivatives
            call me%ogeval(me%Varval,me%Conval,me%Varder,conder_tmp)
            me%Conder(1:me%Numcon+1,:) = conder_tmp
         end subroutine evaluation_func_and_der

   end subroutine ogexec