CORRECTION PART
2008/01/16 | J. SCHOENMAEKERS | NEW
| Type | Intent | Optional | Attributes | Name | ||
|---|---|---|---|---|---|---|
| class(optgra), | intent(inout) | :: | me | |||
| real(kind=wp), | intent(inout) | :: | Varacc | |||
| integer(kind=ip), | intent(out) | :: | Finish | |||
| real(kind=wp) | :: | Toterr | ||||
| real(kind=wp) | :: | Norerr | ||||
| logical, | intent(out) | :: | error |
if there was a fatal error |
subroutine ogcorr(me,Varacc,Finish,Toterr,Norerr,error) !! CORRECTION PART !! !! 2008/01/16 | J. SCHOENMAEKERS | NEW class(optgra),intent(inout) :: me real(wp),intent(inout) :: Varacc integer(ip),intent(out) :: Finish real(wp) :: Toterr real(wp) :: Norerr logical,intent(out) :: error !! if there was a fatal error integer(ip) :: coritr , numfff , minpri , maxpri , curpri, & conind , norind , inelop , maxitr, & con , var , act , ind , len , cos , stp, & typ , cor , pri , vio , fff real(wp) :: cornor , foldis , cstval , conerr, & corinv , varvio , conmax , normax, & val , fac , upr , del , co2 , co1 , co0 , de2 , dis, & eps , err , dlt , sca , dif , exc character(len=str_len) :: str character(len=name_len) :: nam real(wp) , dimension(:) , allocatable :: cosact real(wp) , dimension(:) , allocatable :: varvec real(wp) , dimension(:) , allocatable :: varsav real(wp) , dimension(:) , allocatable :: varcor real(wp) , dimension(:) , allocatable :: corvec real(wp) , dimension(:) , allocatable :: consav integer(ip) , dimension(:) , allocatable :: conttt integer(ip) , dimension(:) , allocatable :: concor integer(ip) , dimension(:) , allocatable :: coninc integer(ip) , dimension(:) , allocatable :: conhit integer(ip) , dimension(:) , allocatable :: fffcon integer(ip) , dimension(:) , allocatable :: prisav integer :: ido !! for a dispatch loop that replaced the original gotos error = .false. ! initialize - JW : these could also be in the class. ! that would save the allocate/reallocate ! step every time this routine is called. allocate (cosact(me%Numvar)) allocate (varvec(me%Numvar)) allocate (varsav(me%Numvar)) allocate (varcor(me%Numvar)) allocate (corvec(me%Numvar)) allocate (consav(me%Numcon+1)) allocate (conttt(me%Numcon+1)) allocate (concor(me%Numcon)) allocate (coninc(me%Numcon)) allocate (conhit(me%Numcon)) allocate (fffcon(me%Numcon)) allocate (prisav(me%Numcon)) ! ====================================================================== ! CORRECTION PART ! ---------------------------------------------------------------------- coritr = 0 maxitr = 10 if ( me%Senopt/=0 ) maxitr = 1 ! ====================================================================== cos = me%Numcon + 1 vio = me%Numcon + 2 stp = 0 Finish = 0 eps = 1.0e-03_wp dlt = 1.0e-06_wp varvio = me%Varmax*1.0e+03_wp numfff = me%Numact fffcon = me%Actcon conttt = me%Contyp prisav = me%Conpri concor = 0 ! ---------------------------------------------------------------------- minpri = 1000 maxpri = -1000 do con = 1 , me%Numcon if ( me%Contyp(con)==-2 ) cycle minpri = min(minpri,me%Conpri(con)) maxpri = max(maxpri,me%Conpri(con)) end do ind = 0 if ( numfff>0 ) ind = 1 if ( me%Senopt>0 ) ind = 1 minpri = minpri - ind call me%ogwrit(3,"") call me%ogwrit(3,"PRIORITISE CONSTRAINTS") call me%ogwrit(3,"") if ( me%Senopt<=0 ) then do fff = 1 , numfff con = fffcon(fff) nam = me%Constr(con) len = me%Conlen(con) typ = me%Contyp(con) write (str,'("PRI",1X,I4,1X,I4,1X,A)') con , typ , nam(1:len) call me%ogwrit(3,str) me%Conpri(con) = minpri end do end if if ( me%Senopt>0 ) then do con = 1 , me%Numcon if ( me%Contyp(con)==-2 ) cycle if ( me%Senact(con)<=0 ) cycle nam = me%Constr(con) len = me%Conlen(con) typ = me%Contyp(con) write (str,'("PRI",1X,I4,1X,I4,1X,A)') con , typ , nam(1:len) call me%ogwrit(3,str) me%Conpri(con) = minpri end do end if call me%ogwrit(3,"") ido = 2 ! start the loop main: do select case (ido) case (2) ! ====================================================================== ! Evaluation loop ! ---------------------------------------------------------------------- write (str,'("CORITR=",I2,1X,I2)') coritr , maxitr call me%ogwrit(3,str) call me%ogwrit(3,"") ! ====================================================================== ! Inequality loop ! ---------------------------------------------------------------------- inelop = 2 if ( numfff>0 ) inelop = 1 if ( me%Senopt>0 ) inelop = 1 varsav = me%Varval consav = me%Conval ido = 3 case (3) ! ---------------------------------------------------------------------- write (str,'("INELOP=",I2)') inelop call me%ogwrit(3,str) call me%ogwrit(3,"") ! ---------------------------------------------------------------------- me%Varval = varsav me%Conval = consav me%Contyp = conttt if ( inelop==1 ) then do fff = 1 , numfff con = fffcon(fff) nam = me%Constr(con) len = me%Conlen(con) typ = me%Contyp(con) write (str,'("TYP",1X,I4,1X,I4,1X,A)') con , typ , nam(1:len) call me%ogwrit(3,str) me%Contyp(con) = 0 end do end if if ( inelop==1 .and.me%Senopt>0 ) then do con = 1 , me%Numcon if ( me%Contyp(con)==-2 ) cycle if ( me%Senact(con)<=0 ) cycle nam = me%Constr(con) len = me%Conlen(con) typ = me%Contyp(con) write (str,'("FIX",1X,I4,1X,I4,1X,A)') con , typ , nam(1:len) call me%ogwrit(2,str) me%Contyp(con) = 0 end do end if me%Numact = 0 me%Conact = 0 me%Conred(1:me%Numcon+1,:) = me%Conder(1:me%Numcon+1,:) ! CONRED=constraint gradient matrix (scaled) me%Conred(me%Numcon+2,:) = me%Vardir ! ---------------------------------------------------------------------- ! CHECK CONSTRAINTS ! ---------------------------------------------------------------------- conerr = 0.0_wp Norerr = 0.0_wp conind = 0 norind = 0 conmax = 0.0_wp normax = 0.0_wp do con = 1 , me%Numcon if ( me%Contyp(con)==-2 ) cycle typ = me%Contyp(con) val = me%Conval(con) if ( val<-1.0_wp ) then err = abs(val) elseif ( typ/=0 ) then err = 0.0_wp elseif ( val>1.0_wp ) then err = abs(val) else err = 0.0_wp end if conerr = conerr + err if ( err>conmax ) then conind = con conmax = err end if fac = 0.0_wp do var = 1 , me%Numvar if ( me%Vartyp(var)==1 ) cycle fac = fac + me%Conder(con,var)**2 end do fac = sqrt(fac) if ( err==0.0_wp ) then elseif ( fac/=0.0_wp ) then err = err/fac else call me%ogwrit(0,"") call me%ogwrit(0,"ERROR: CONSTRAINT CAN NOT BE SATISFIED") write (str,'("CON/VAL= ",I5,1X,D13.6)') con , val call me%ogwrit(0,str) Finish = 0 call done() exit main end if Norerr = Norerr + err if ( err>normax ) then norind = con normax = err end if end do ! ---------------------------------------------------------------------- Toterr = conerr call me%ogwrit(3,"") write (str,'("NUMFFF/TOTERR/NORERR/COSVAL=",I4,3(1X,D13.6))') & numfff , Toterr , Norerr , me%Conval(me%Numcon+1) call me%ogwrit(2,str) call me%ogwrit(3,"") write (str,'("MAXIM TOTAL ERROR.: ",D13.6,I6)') conmax , conind call me%ogwrit(3,str) write (str,'("MAXIM NORM ERROR.: ",D13.6,I6)') normax , norind call me%ogwrit(3,str) ! ---------------------------------------------------------------------- if ( me%Senopt>0 .and. coritr==maxitr ) then if ( cstval==0.0_wp ) then Finish = 1 else Finish = 0 end if exit main end if if ( coritr==0 .and. conerr==0.0_wp ) then me%Numact = numfff me%Actcon = fffcon Finish = 1 exit main elseif ( coritr/=0 .and. conerr==0.0_wp ) then Finish = 1 exit main elseif ( coritr==maxitr ) then Finish = 0 call me%ogwrit(3,"") write (str,'("CORITR=",I2)') coritr call me%ogwrit(3,str) exit main else Finish = 0 coritr = coritr + 1 end if ! ====================================================================== ! Priority loop ! ---------------------------------------------------------------------- curpri = minpri ido = 4 case (4) ! ---------------------------------------------------------------------- write (str,'("CURPRI=",I2,1X,I2)') curpri , maxpri call me%ogwrit(3,str) call me%ogwrit(3,"") ! ====================================================================== ! MINIMUM NORM CORRECTION ! ---------------------------------------------------------------------- call me%ogwrit(3,"") write (str,'("CORRECTION OF CONSTRAINTS")') call me%ogwrit(3,str) call me%ogwrit(3,"") write (str,*) "INELOP/CURPRI=" , inelop , curpri call me%ogwrit(3,str) ! ---------------------------------------------------------------------- conerr = 0.0_wp do con = 1 , me%Numcon if ( me%Contyp(con)==-2 ) cycle conhit(con) = 0 if ( me%Conval(con)<-eps ) then conerr = conerr + abs(me%Conval(con)) elseif ( me%Contyp(con)/=0 ) then elseif ( me%Conval(con)>+eps ) then conerr = conerr + abs(me%Conval(con)) end if end do ! ---------------------------------------------------------------------- call me%ogwrit(3,"") write (str,'("LINEAR ERROR.: ",D13.6)') conerr call me%ogwrit(3,str) ! ---------------------------------------------------------------------- call me%ogwrit(3,"") write (str,'(" ACT PAS MOV",'//' " COST___VAL COST___GRD",'//' " DIST___DEL CONSTRAINT")') call me%ogwrit(3,str) ido = 5 case (5) ! ====================================================================== ! Move loop ! ---------------------------------------------------------------------- do con = 1 , me%Numcon if ( me%Contyp(con)==-2 ) cycle coninc(con) = 0 pri = me%Conpri(con) val = me%Conval(con) typ = me%Contyp(con) act = me%Conact(con) cor = concor(con) if ( act>0 ) cycle if ( pri>curpri ) then me%Conact(con) = -1 elseif ( val<-dlt ) then me%Conact(con) = -1 elseif ( val>+dlt ) then me%Conact(con) = -1 else me%Conact(con) = 0 end if if ( pri>curpri ) then concor(con) = 0 elseif ( val<-dlt ) then concor(con) = -1 elseif ( typ/=0 ) then concor(con) = 0 elseif ( val>+dlt ) then concor(con) = +1 else concor(con) = 0 end if ! IF (ACT /= CONACT(CON) .OR. COR /= CONCOR(CON)) THEN ! NAM = CONSTR(CON) ! LEN = CONLEN(CON) ! WRITE (STR,'(5X,5X,I4,23X,D10.3,1X,A,4I4)') & ! CON, CONVAL(CON),NAM(1:LEN), & ! CONACT(CON),CONCOR(CON), ACT, COR ! CALL me%ogwrit (3,STR) ! end if end do ! ====================================================================== ! STEEPEST ASCENT VECTOR ! ====================================================================== ! MERIT VALUE AND DERIVATIVES ! ---------------------------------------------------------------------- cstval = 0.0_wp varvec = 0.0_wp me%Conred(vio,:) = 0.0_wp ! ---------------------------------------------------------------------- do con = 1 , me%Numcon if ( me%Contyp(con)==-2 ) cycle if ( me%Conpri(con)>curpri ) cycle if ( concor(con)==0 ) cycle fac = concor(con) cstval = cstval - me%Conval(con)*fac me%Conred(vio,:) = me%Conred(vio,:) - me%Conred(con,:)*fac varvec = varvec - me%Conder(con,:)*fac end do inner: do ! ---------------------------------------------------------------------- ! STEEPEST ASCENT VECTOR ! ---------------------------------------------------------------------- corvec = me%Conred(vio,:) ! ---------------------------------------------------------------------- cornor = sqrt(sum(corvec(me%Numact+1:me%Numvar)**2)) ! ---------------------------------------------------------------------- ! MERIT PARTIAL W.R.T. CONSTRAINTS ! ---------------------------------------------------------------------- cosact = me%ogrigt(corvec) ! ---------------------------------------------------------------------- ! CONSTRAINT REMOVAL ! ---------------------------------------------------------------------- ind = 0 exc = 1.0e-12_wp upr = exc do act = 1 , me%Numact con = me%Actcon(act) if ( me%Contyp(con)==0 ) cycle val = cosact(act) if ( val<=exc ) cycle if ( val<upr ) cycle ! IF (VAL >= UPR .AND. UPR > 0.0_wp) CYCLE upr = val ind = act end do ! ---------------------------------------------------------------------- if ( ind/=0 ) then con = me%Actcon(ind) nam = me%Constr(con) len = me%Conlen(con) write (str,'(5X,I4,5X,3(1X,D10.3),1X,A)') con , cstval , cornor , upr , nam(1:len) call me%ogwrit(3,str) call me%ogexcl(ind,error) if (error) return if ( coninc(con)>=5 ) then write (str,'("OGCORR-WARNING: CONSTRAINT INCLUDED")') call me%ogwrit(1,str) write (str,'("CON/INC/UPR=",2I4,1X,D10.3)') con , coninc(con) , upr call me%ogwrit(1,str) end if if ( coninc(con)>=20 ) then Finish = 0 call done() exit main end if cycle end if ! ---------------------------------------------------------------------- ! NORMALISE STEEPEST ASCEND VECTOR ! ---------------------------------------------------------------------- if ( cstval<-cornor*varvio ) exit inner ! ---------------------------------------------------------------------- corinv = 1.0_wp/cornor corvec(me%Numact+1:me%Numvar) = corvec(me%Numact+1:me%Numvar)*corinv ! ---------------------------------------------------------------------- ! CONSTRAINT INCLUSION ! ---------------------------------------------------------------------- ind = 0 upr = 0.0_wp ! ---------------------------------------------------------------------- do con = 1 , me%Numcon if ( me%Contyp(con)==-2 ) cycle if ( me%Conpri(con)>curpri ) cycle if ( me%Conact(con)/=0 ) cycle del = dot_product(me%Conred(con,me%Numact+1:me%Numvar),me%Conred(vio,me%Numact+1:me%Numvar)) val = abs(del)*me%Varmax/cornor if ( val<eps ) cycle fac = dot_product(me%Conred(con,1:me%Numvar),me%Conred(con,1:me%Numvar)) del = del/sqrt(fac) if ( del<upr ) then upr = del ind = con end if if ( me%Contyp(con)/=0 ) cycle if ( concor(con)/=0 ) cycle del = -del if ( del<upr ) then upr = del ind = con end if end do ! ---------------------------------------------------------------------- if ( ind/=0 ) then con = ind nam = me%Constr(con) len = me%Conlen(con) write (str,'(I4,5X,5X,3(1X,D10.3),1X,A)') con , cstval , cornor , upr , nam(1:len) call me%ogwrit(3,str) call me%ogincl(ind) coninc(con) = coninc(con) + 1 cycle inner end if exit inner end do inner ! ---------------------------------------------------------------------- do var = 1 , me%Numvar val = varvec(var) do act = 1 , me%Numact con = me%Actcon(act) val = val - me%Conder(con,var)*cosact(act) end do varvec(var) = val*corinv end do ! ---------------------------------------------------------------------- varcor = me%Varval - me%Varref co2 = dot_product(varvec,varvec) co1 = dot_product(varvec,varcor)*0.5_wp co0 = dot_product(varcor,varcor) - me%Varmax**2 de2 = co1**2 - co2*co0 if ( de2>=0.0_wp .and. co2/=0.0_wp ) then dis = (sqrt(de2)-co1)/co2 else dis = 0.0_wp end if ! ---------------------------------------------------------------------- do var = 1 , me%Numvar fac = varvec(var) if ( fac==0.0_wp ) cycle dif = me%Varval(var) - me%Varref(var) sca = me%Varmax*1.0e-0_wp ! JW : why is this multiplied by 1 ? val = (dif+sca)/fac fac = (dif-sca)/fac if ( fac>val ) val = fac if ( val<dis ) dis = val end do dis = max(dis, 0.0_wp) ! ---------------------------------------------------------------------- foldis = dis ! ====================================================================== ! OPTIMISE DIRETION OF STEPPEST ASCENT ! ====================================================================== if ( cstval==0.0_wp ) then ! ---------------------------------------------------------------------- ! WRITE (STR,'("CNV=",3(1X,D10.3))') CSTVAL/CORNOR/VARVIO ! CALL me%ogwrit (3,STR) write (str,'(4X,5X,5X,3(1X,D10.3))') cstval , cornor , foldis call me%ogwrit(3,str) call me%ogwrit(3,"") if ( curpri>=maxpri ) then write (str,'("MAXPRI=",I3)') maxpri call me%ogwrit(3,str) ! ====================================================================== ! MATCHED INEQUALITY CONSTRAINTS + MINIMUM CORRECTION NORM ! ---------------------------------------------------------------------- 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 ! ====================================================================== if ( me%Senopt<=0 ) call me%ogeval(me%Varval,me%Conval,0,me%Conder) ido = 2 cycle main else write (str,'("CURPRI=",I3)') curpri call me%ogwrit(3,str) curpri = curpri + 1 ido = 4 cycle main end if ! ---------------------------------------------------------------------- elseif ( cstval<-cornor*varvio ) then ! ---------------------------------------------------------------------- write (str,'("CNV=",3(1X,D10.3))') cstval/cornor/varvio call me%ogwrit(2,str) call me%ogwrit(3,"") write (str,'("CSTVAL=",3D10.3)') cstval , cornor , varvio call me%ogwrit(3,str) if ( inelop==1 ) then write (str,'("INELOP=",I3)') inelop call me%ogwrit(3,str) inelop = inelop + 1 ido = 3 cycle main else Finish = 0 exit main end if ! ---------------------------------------------------------------------- end if ! ====================================================================== ! IF CONSTRAINT IS HIT ! ---------------------------------------------------------------------- ind = 0 do con = 1 , me%Numcon if ( me%Contyp(con)==-2 ) cycle if ( me%Conact(con)/=-1 ) cycle val = dot_product(me%Conred(con,me%Numact+1:me%Numvar),corvec(me%Numact+1:me%Numvar)) if ( val==0.0_wp ) cycle val = -me%Conval(con)/val if ( val<=0.0_wp ) cycle if ( val>=foldis ) cycle foldis = val ind = con end do ! ====================================================================== ! UPDATE VARIABLES, CONSTRAINTS AND COST FUNCTION ! ---------------------------------------------------------------------- varvec = varvec*foldis ! ---------------------------------------------------------------------- Varacc = Varacc + foldis me%Varval = me%Varval + varvec ! ---------------------------------------------------------------------- do con = 1 , me%Numcon + 1 val = dot_product(corvec(me%Numact+1:me%Numvar),me%Conred(con,me%Numact+1:me%Numvar)) me%Conval(con) = me%Conval(con) + val*foldis end do ! ---------------------------------------------------------------------- cstval = cstval + foldis*cornor ! ====================================================================== ! MAXIMUM TRAVEL DISTANCE REACHED: NEXT ITERATION ! ---------------------------------------------------------------------- if ( ind==0 ) then write (str,'("CNV=",3(1X,D10.3))') cstval/cornor/varvio call me%ogwrit(3,str) write (str,'(4X,5X,5X,3(1X,D10.3))') cstval , cornor , foldis call me%ogwrit(3,str) if ( inelop==1 ) then write (str,'("INELOP=",I3)') inelop call me%ogwrit(3,str) inelop = inelop + 1 ido = 3 cycle main else me%Numact = 0 exit main end if end if ! ====================================================================== ! CONSTRAINT HIT: UPDATE CONSTRAINTS + CORRECT ! ---------------------------------------------------------------------- con = ind nam = me%Constr(con) len = me%Conlen(con) val = me%Conval(con) write (str,'(5X,5X,I4,3(1X,D10.3),1X,A)') con , cstval , cornor , foldis , nam(1:len) call me%ogwrit(3,str) if ( conhit(con)>=20 ) then write (str,'("OGCORR-WARNING: CONSTRAINT HIT")') call me%ogwrit(1,str) write (str,'("CON/HIT=",2I4)') con , conhit(con) call me%ogwrit(1,str) Finish = 0 call done() exit main end if ! ---------------------------------------------------------------------- conhit(con) = conhit(con) + 1 ido = 5 cycle main end select end do main ! ====================================================================== ! MATCHED INEQUALITY CONSTRAINTS + MINIMUM CORRECTION NORM ! ---------------------------------------------------------------------- call me%ogwrit(3,"") write (str,'("CSTVAL:",D13.6)') cstval call me%ogwrit(3,str) 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 ! ---------------------------------------------------------------------- call me%ogwrit(3,"") call me%ogwrit(3,"STATUS OF VIOLATED CONSTRAINTS:") call me%ogwrit(3,"") call me%ogwrit(3," CON COST___VAL CONSTRAINT") conerr = 0.0_wp do con = 1 , me%Numcon if ( me%Contyp(con)==-2 ) cycle nam = me%Constr(con) len = me%Conlen(con) val = me%Conval(con) if ( val<-dlt ) then conerr = conerr + abs(val) write (str,'( I4,D11.3,1X,A)') con , val , nam(1:len) call me%ogwrit(3,str) elseif ( me%Contyp(con)/=0 ) then elseif ( val>dlt ) then conerr = conerr + abs(val) write (str,'( I4,D11.3,1X,A)') con , val , nam(1:len) call me%ogwrit(3,str) end if end do ! ---------------------------------------------------------------------- call me%ogwrit(3,"") write (str,'("LINEAR ERROR.: ",D13.6)') conerr call me%ogwrit(3,str) call done() contains subroutine done() ! 7 me%Contyp = conttt me%Conpri = prisav deallocate (cosact) deallocate (varvec) deallocate (varsav) deallocate (varcor) deallocate (corvec) deallocate (consav) deallocate (conttt) deallocate (concor) deallocate (coninc) deallocate (conhit) deallocate (fffcon) deallocate (prisav) end subroutine done end subroutine ogcorr