!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
!
subroutine grtest2(simul,na_stdout,na_dim,da_x0,na_range) 4
implicit none
! Dummies
integer, intent(in) :: na_dim ! Size of the control vector
integer, intent(in) :: na_range ! the test will be carried over values of
! ALPHA ranging between
! 10**(-NA_RANGE) < ALPHA < 0.1
integer, intent(in) :: na_stdout ! Standard ouput logical unit
real*8, intent(in), dimension(na_dim) :: da_x0 ! Control vector
external simul ! simulator: return cost function estimate and its gradient
!
!Purpose:
!to compare the variation of the functional against what the gradient
!gives for small changes in the control variable. This test should be
!accurate for values as small as DLALPHA = SQRT(machine precision).
!(see Courtier, 1987)
!
!Author : P. Gauthier *ARMA/AES June 9, 1992
!
!Revision:
!
! JM Belanger CMDA/SMC Oct 2000
! . 32 bits conversion
! P. Gauthier ARMA/MSC July 2003
! . Set the output unit through an argument
! S. Pellerin ARMA/MSC Oct. 2005
! . Introduction of call back simulator
! . Automatic array (argument cleanup)
! . F90 free style and ODA Norm coding
!
! Local delcarations
integer :: nl_indic, nl_j
real*8 :: dl_wrk(na_dim),dl_gradj0(na_dim), dl_x(na_dim)
real*8 :: dl_J0, dl_J, dl_test, dl_start,dl_end
real*8 :: dl_alpha, dl_gnorm0
! 1. Initialize dl_gradj0 at da_x0
! ------------------------------------
nl_indic = 2
call simul(nl_indic,na_dim,da_x0,dl_j0,dl_gradj0)
dl_gnorm0 = dot_product(dl_gradj0,dl_gradj0)
dl_start = 1.d0
dl_end = 10.0d0**(-na_range)
write(na_stdout,FMT=9100) dl_start,dl_end, dl_j0, dl_gnorm0
! 2. Perform the test
! ----------------
if(dl_gnorm0.eq.0.d0)then
write(na_stdout,FMT=9101)
return
end if
write(na_stdout,FMT=9200)
do nl_j = 1, na_range
dl_alpha = 10.0d0**(- nl_j)
dl_x(:) = da_x0(:) - dl_alpha*dl_gradJ0(:)
call simul(nl_indic,na_dim,dl_x,dl_j,dl_wrk)
dl_test = (dl_j-dl_j0)/(-dl_alpha * dl_gnorm0)
write(na_stdout,FMT=9201)nl_j, dl_alpha, dl_j, dl_test
end do
9100 format(//,4X,&
'GRTEST- The gradient is being tested for',&
G23.16,' <= ALPHA <= ',G23.16,/,12X,&
'Initial value of J(X):',1x,G23.16,4x,&
'Norm of GRAD J(X)**2: ',G23.16)
9101 format(/,4X,'-In GRTEST: gradient vanishes exactly',&
'. Gradient test cannot be performed at this point')
9200 format(/,4X,'J',8X,'ALPHA',11X,'J(X)',12X,'TEST')
9201 format(2X,'GRTEST: step',2X,I3,4X,G23.16,4X,G23.16,4X,&
G23.16)
return
end subroutine grtest2