ROMS
Loading...
Searching...
No Matches
Functions/Subroutines
cgradient_mod Module Reference

Functions/Subroutines

subroutine, public cgradient (ng, tile, model, innloop, outloop)
 
subroutine, private cgradient_tile (ng, tile, model, lbi, ubi, lbj, ubj, lbij, ubij, imins, imaxs, jmins, jmaxs, lold, lnew, innloop, outloop, rmask, umask, vmask, nl_t_obc, nl_u_obc, nl_v_obc, nl_ubar_obc, nl_vbar_obc, nl_zeta_obc, nl_ustr, nl_vstr, nl_tflux, nl_t, nl_u, nl_v, nl_zeta, tl_t_obc, tl_u_obc, tl_v_obc, tl_ubar_obc, tl_vbar_obc, tl_zeta_obc, tl_ustr, tl_vstr, tl_tflux, tl_t, tl_u, tl_v, tl_zeta, d_t_obc, d_u_obc, d_v_obc, d_ubar_obc, d_vbar_obc, d_zeta_obc, d_sustr, d_svstr, d_stflx, d_t, d_u, d_v, d_zeta, ad_t_obc, ad_u_obc, ad_v_obc, ad_ubar_obc, ad_vbar_obc, ad_zeta_obc, ad_ustr, ad_vstr, ad_tflux, ad_t, ad_u, ad_v, ad_zeta)
 
subroutine, private tl_new_state (ng, tile, model, lbi, ubi, lbj, ubj, lbij, ubij, imins, imaxs, jmins, jmaxs, linp, lout, innloop, outloop, rmask, umask, vmask, d_t_obc, d_u_obc, d_v_obc, d_ubar_obc, d_vbar_obc, d_zeta_obc, d_sustr, d_svstr, d_stflx, d_t, d_u, d_v, d_zeta, tl_t_obc, tl_u_obc, tl_v_obc, tl_ubar_obc, tl_vbar_obc, tl_zeta_obc, tl_ustr, tl_vstr, tl_tflux, tl_t, tl_u, tl_v, tl_zeta, ad_t_obc, ad_u_obc, ad_v_obc, ad_ubar_obc, ad_vbar_obc, ad_zeta_obc, ad_ustr, ad_vstr, ad_tflux, ad_t, ad_u, ad_v, ad_zeta)
 
subroutine, private new_direction (ng, tile, model, lbi, ubi, lbj, ubj, lbij, ubij, imins, imaxs, jmins, jmaxs, lold, lnew, rmask, umask, vmask, ad_t_obc, ad_u_obc, ad_v_obc, ad_ubar_obc, ad_vbar_obc, ad_zeta_obc, ad_ustr, ad_vstr, ad_tflux, ad_t, ad_u, ad_v, ad_zeta, d_t_obc, d_u_obc, d_v_obc, d_ubar_obc, d_vbar_obc, d_zeta_obc, d_sustr, d_svstr, d_stflx, d_t, d_u, d_v, d_zeta)
 
subroutine, private hessian (ng, tile, model, lbi, ubi, lbj, ubj, lbij, ubij, imins, imaxs, jmins, jmaxs, lold, lnew, lwrk, innloop, outloop, rmask, umask, vmask, ad_t_obc, ad_u_obc, ad_v_obc, ad_ubar_obc, ad_vbar_obc, ad_zeta_obc, ad_ustr, ad_vstr, ad_tflux, ad_t, ad_u, ad_v, ad_zeta, tl_t_obc, tl_u_obc, tl_v_obc, tl_ubar_obc, tl_vbar_obc, tl_zeta_obc, tl_ustr, tl_vstr, tl_tflux, tl_t, tl_u, tl_v, tl_zeta)
 
subroutine, private lanczos (ng, tile, model, lbi, ubi, lbj, ubj, lbij, ubij, imins, imaxs, jmins, jmaxs, lold, lnew, lwrk, innloop, outloop, rmask, umask, vmask, tl_t_obc, tl_u_obc, tl_v_obc, tl_ubar_obc, tl_vbar_obc, tl_zeta_obc, tl_ustr, tl_vstr, tl_tflux, tl_t, tl_u, tl_v, tl_zeta, ad_t_obc, ad_u_obc, ad_v_obc, ad_ubar_obc, ad_vbar_obc, ad_zeta_obc, ad_ustr, ad_vstr, ad_tflux, ad_t, ad_u, ad_v, ad_zeta)
 
subroutine, private new_gradient (ng, tile, model, lbi, ubi, lbj, ubj, lbij, ubij, imins, imaxs, jmins, jmaxs, lold, lnew, lwrk, innloop, outloop, rmask, umask, vmask, tl_t_obc, tl_u_obc, tl_v_obc, tl_ubar_obc, tl_vbar_obc, tl_zeta_obc, tl_ustr, tl_vstr, tl_tflux, tl_t, tl_u, tl_v, tl_zeta, ad_t_obc, ad_u_obc, ad_v_obc, ad_ubar_obc, ad_vbar_obc, ad_zeta_obc, ad_ustr, ad_vstr, ad_tflux, ad_t, ad_u, ad_v, ad_zeta)
 
subroutine, private hessian_evecs (ng, tile, model, lbi, ubi, lbj, ubj, lbij, ubij, imins, imaxs, jmins, jmaxs, lold, lnew, lwrk, innloop, outloop, rmask, umask, vmask, nl_t_obc, nl_u_obc, nl_v_obc, nl_ubar_obc, nl_vbar_obc, nl_zeta_obc, nl_ustr, nl_vstr, nl_tflux, nl_t, nl_u, nl_v, nl_zeta, tl_t_obc, tl_u_obc, tl_v_obc, tl_ubar_obc, tl_vbar_obc, tl_zeta_obc, tl_ustr, tl_vstr, tl_tflux, tl_t, tl_u, tl_v, tl_zeta, ad_t_obc, ad_u_obc, ad_v_obc, ad_ubar_obc, ad_vbar_obc, ad_zeta_obc, ad_ustr, ad_vstr, ad_tflux, ad_t, ad_u, ad_v, ad_zeta)
 
subroutine, private new_cost (ng, tile, model, lbi, ubi, lbj, ubj, lbij, ubij, imins, imaxs, jmins, jmaxs, innloop, outloop, rmask, umask, vmask, nl_t_obc, nl_u_obc, nl_v_obc, nl_ubar_obc, nl_vbar_obc, nl_zeta_obc, nl_ustr, nl_vstr, nl_tflux, nl_t, nl_u, nl_v, nl_zeta)
 
subroutine, private precond (ng, tile, model, message, lbi, ubi, lbj, ubj, lbij, ubij, imins, imaxs, jmins, jmaxs, nstatevars, lscale, ltrans, innloop, outloop, rmask, umask, vmask, nl_t_obc, nl_u_obc, nl_v_obc, nl_ubar_obc, nl_vbar_obc, nl_zeta_obc, nl_ustr, nl_vstr, nl_tflux, nl_t, nl_u, nl_v, nl_zeta)
 
subroutine, private cg_write_cgradient (ng, model, innloop, outloop)
 
subroutine, private cg_write_cgradient_nf90 (ng, model, innloop, outloop)
 
subroutine, private cg_write_cgradient_pio (ng, model, innloop, outloop)
 
subroutine, public cg_read_cgradient (ng, model, outloop)
 
subroutine, private cg_read_cgradient_nf90 (ng, model, outloop)
 
subroutine, private cg_read_cgradient_pio (ng, model, outloop)
 

Function/Subroutine Documentation

◆ cg_read_cgradient()

subroutine, public cgradient_mod::cg_read_cgradient ( integer, intent(in) ng,
integer, intent(in) model,
integer, intent(in) outloop )

Definition at line 7535 of file cgradient.F.

7536!***********************************************************************
7537! !
7538! If split 4D-Var and outer>1, this routine reads conjugate gradient !
7539! variables for previous outer loops from 4D-Var NetCDF (DAV) file. !
7540! !
7541!***********************************************************************
7542!
7543! Imported variable declarations
7544!
7545 integer, intent(in) :: ng, model, outLoop
7546!
7547! Local variable declarations.
7548!
7549 integer :: status
7550!
7551 character (len=*), parameter :: MyFile = &
7552 & __FILE__//", cg_read_cgradient"
7553!
7554 sourcefile=myfile
7555!
7556!-----------------------------------------------------------------------
7557! Read in conjugate gradient variables.
7558!-----------------------------------------------------------------------
7559!
7560 SELECT CASE (dav(ng)%IOtype)
7561 CASE (io_nf90)
7562 CALL cg_read_cgradient_nf90 (ng, model, outloop)
7563
7564# if defined PIO_LIB && defined DISTRIBUTE
7565 CASE (io_pio)
7566 CALL cg_read_cgradient_pio (ng, model, outloop)
7567# endif
7568 CASE DEFAULT
7569 IF (master) WRITE (stdout,10) dav(ng)%IOtype
7570 exit_flag=3
7571 END SELECT
7572 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7573!
7574 10 FORMAT (' CG_READ_CGRADIENT - Illegal output type, io_type = ',i0)
7575!
7576 RETURN

References cg_read_cgradient_nf90(), cg_read_cgradient_pio(), mod_iounits::dav, mod_scalars::exit_flag, strings_mod::founderror(), mod_ncparam::io_nf90, mod_ncparam::io_pio, mod_parallel::master, mod_scalars::noerror, mod_iounits::sourcefile, and mod_iounits::stdout.

Referenced by i4dvar_mod::increment().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ cg_read_cgradient_nf90()

subroutine, private cgradient_mod::cg_read_cgradient_nf90 ( integer, intent(in) ng,
integer, intent(in) model,
integer, intent(in) outloop )
private

Definition at line 7580 of file cgradient.F.

7581!***********************************************************************
7582!
7583! Imported variable declarations
7584!
7585 integer, intent(in) :: ng, model, outLoop
7586!
7587! Local variable declarations.
7588!
7589 integer :: status
7590!
7591 character (len=*), parameter :: MyFile = &
7592 & __FILE__//", cg_read_cgradient_nf90"
7593!
7594 sourcefile=myfile
7595!
7596!-----------------------------------------------------------------------
7597! If split 4D-Var and outer>1, Read in conjugate gradient variables
7598! four outerloop restart.
7599!-----------------------------------------------------------------------
7600!
7601! Open DAV NetCDF file for reading.
7602!
7603 IF (dav(ng)%ncid.eq.-1) THEN
7604 CALL netcdf_open (ng, model, dav(ng)%name, 1, dav(ng)%ncid)
7605 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7606 END IF
7607!
7608! Read in number of converged Ritz eigenvalues
7609!
7610 CALL netcdf_get_ivar (ng, model, dav(ng)%name, &
7611 & 'nConvRitz', nconvritz, &
7612 & ncid = dav(ng)%ncid, &
7613 & start = (/outloop-1/), &
7614 & total = (/1/))
7615 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7616!
7617! Read in converged Ritz eigenvalues.
7618!
7619 CALL netcdf_get_fvar (ng, model, dav(ng)%name, &
7620 & 'Ritz', ritz, &
7621 & ncid = dav(ng)%ncid, &
7622 & start = (/1/), &
7623 & total = (/ninner/))
7624 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7625!
7626! Read in conjugate gradient "beta" coefficients.
7627!
7628 CALL netcdf_get_fvar (ng, model, dav(ng)%name, &
7629 & 'cg_beta', cg_beta, &
7630 & ncid = dav(ng)%ncid, &
7631 & start = (/1,1/), &
7632 & total = (/ninner+1,outloop-1/))
7633 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7634!
7635! Read in conjugate gradient "delta" coefficients.
7636!
7637 CALL netcdf_get_fvar (ng, model, dav(ng)%name, &
7638 & 'cg_delta', cg_delta, &
7639 & ncid = dav(ng)%ncid, &
7640 & start = (/1,1/), &
7641 & total = (/ninner,outloop-1/))
7642 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7643!
7644! Read in conjugate gradient "gamma" coefficients.
7645!
7646 CALL netcdf_get_fvar (ng, model, dav(ng)%name, &
7647 & 'cg_gamma', cg_gamma, &
7648 & ncid = dav(ng)%ncid, &
7649 & start = (/1,1/), &
7650 & total = (/ninner,outloop-1/))
7651 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7652!
7653! Read in initial gradient normalization factor.
7654!
7655 CALL netcdf_get_fvar (ng, model, dav(ng)%name, &
7656 & 'cg_Gnorm', cg_gnorm, &
7657 & ncid = dav(ng)%ncid, &
7658 & start = (/1/), &
7659 & total = (/outloop-1/))
7660 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7661!
7662! Read in Lanczos vector normalization factor.
7663!
7664 CALL netcdf_get_fvar (ng, model, dav(ng)%name, &
7665 & 'cg_QG', cg_qg, &
7666 & ncid = dav(ng)%ncid, &
7667 & start = (/1,1/), &
7668 & total = (/ninner+1,outloop-1/))
7669 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7670!
7671! Read in reduction in the gradient norm.
7672!
7673 CALL netcdf_get_fvar (ng, model, dav(ng)%name, &
7674 & 'cg_Greduc', cg_greduc, &
7675 & ncid = dav(ng)%ncid, &
7676 & start = (/1,1/), &
7677 & total = (/ninner,outloop-1/))
7678 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7679!
7680! Read in tridiagonal matrix upper diagonal elements.
7681!
7682 CALL netcdf_get_fvar (ng, model, dav(ng)%name, &
7683 & 'cg_zu', cg_zu, &
7684 & ncid = dav(ng)%ncid, &
7685 & start = (/1,1/), &
7686 & total = (/ninner,outloop-1/))
7687 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7688!
7689! Read in eigenvalues of Lanczos recurrence relationship.
7690!
7691 CALL netcdf_get_fvar (ng, model, dav(ng)%name, &
7692 & 'cg_Ritz', cg_ritz, &
7693 & ncid = dav(ng)%ncid, &
7694 & start = (/1,1/), &
7695 & total = (/ninner,outloop-1/))
7696 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7697!
7698! Read eigenvalues relative error.
7699!
7700 CALL netcdf_get_fvar (ng, model, dav(ng)%name, &
7701 & 'cg_RitzErr', cg_ritzerr, &
7702 & ncid = dav(ng)%ncid, &
7703 & start = (/1,1/), &
7704 & total = (/ninner,outloop-1/))
7705 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7706!
7707! Read in eigenvectors of Lanczos recurrence relationship.
7708!
7709 CALL netcdf_get_fvar (ng, model, dav(ng)%name, &
7710 & 'cg_zv', cg_zv, &
7711 & ncid = dav(ng)%ncid, &
7712 & start = (/1,1/), &
7713 & total = (/ninner,ninner/))
7714 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7715!
7716 RETURN

References mod_fourdvar::cg_beta, mod_fourdvar::cg_delta, mod_fourdvar::cg_gamma, mod_fourdvar::cg_gnorm, mod_fourdvar::cg_greduc, mod_fourdvar::cg_qg, mod_fourdvar::cg_ritz, mod_fourdvar::cg_ritzerr, mod_fourdvar::cg_zu, mod_fourdvar::cg_zv, mod_iounits::dav, mod_scalars::exit_flag, strings_mod::founderror(), mod_fourdvar::nconvritz, mod_netcdf::netcdf_open(), mod_scalars::ninner, mod_scalars::noerror, mod_fourdvar::ritz, and mod_iounits::sourcefile.

Referenced by cg_read_cgradient().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ cg_read_cgradient_pio()

subroutine, private cgradient_mod::cg_read_cgradient_pio ( integer, intent(in) ng,
integer, intent(in) model,
integer, intent(in) outloop )
private

Definition at line 7722 of file cgradient.F.

7723!***********************************************************************
7724!
7725! Imported variable declarations
7726!
7727 integer, intent(in) :: ng, model, outLoop
7728!
7729! Local variable declarations.
7730!
7731 integer :: status
7732!
7733 character (len=*), parameter :: MyFile = &
7734 & __FILE__//", cg_read_cgradient_pio"
7735!
7736 sourcefile=myfile
7737!
7738!-----------------------------------------------------------------------
7739! If split 4D-Var and outer>1, Read in conjugate gradient variables
7740! four outerloop restart.
7741!-----------------------------------------------------------------------
7742!
7743! Open DAV NetCDF file for reading.
7744!
7745 IF (dav(ng)%pioFile%fh.eq.-1) THEN
7746 CALL pio_netcdf_open (ng, model, dav(ng)%name, 1, &
7747 & dav(ng)%pioFile)
7748 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7749 END IF
7750!
7751! Read in number of converged Ritz eigenvalues
7752!
7753 CALL pio_netcdf_get_ivar (ng, model, dav(ng)%name, &
7754 & 'nConvRitz', nconvritz, &
7755 & piofile = dav(ng)%pioFile, &
7756 & start = (/outloop-1/), &
7757 & total = (/1/))
7758 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7759!
7760! Read in converged Ritz eigenvalues.
7761!
7762 CALL pio_netcdf_get_fvar (ng, model, dav(ng)%name, &
7763 & 'Ritz', ritz, &
7764 & piofile = dav(ng)%pioFile, &
7765 & start = (/1/), &
7766 & total = (/ninner/))
7767 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7768!
7769! Read in conjugate gradient "beta" coefficients.
7770!
7771 CALL pio_netcdf_get_fvar (ng, model, dav(ng)%name, &
7772 & 'cg_beta', cg_beta, &
7773 & piofile = dav(ng)%pioFile, &
7774 & start = (/1,1/), &
7775 & total = (/ninner+1,outloop-1/))
7776 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7777!
7778! Read in conjugate gradient "delta" coefficients.
7779!
7780 CALL pio_netcdf_get_fvar (ng, model, dav(ng)%name, &
7781 & 'cg_delta', cg_delta, &
7782 & piofile = dav(ng)%pioFile, &
7783 & start = (/1,1/), &
7784 & total = (/ninner,outloop-1/))
7785 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7786!
7787! Read in conjugate gradient "gamma" coefficients.
7788!
7789 CALL pio_netcdf_get_fvar (ng, model, dav(ng)%name, &
7790 & 'cg_gamma', cg_gamma, &
7791 & piofile = dav(ng)%pioFile, &
7792 & start = (/1,1/), &
7793 & total = (/ninner,outloop-1/))
7794 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7795!
7796! Read in initial gradient normalization factor.
7797!
7798 CALL pio_netcdf_get_fvar (ng, model, dav(ng)%name, &
7799 & 'cg_Gnorm', cg_gnorm, &
7800 & piofile = dav(ng)%pioFile, &
7801 & start = (/1/), &
7802 & total = (/outloop-1/))
7803 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7804!
7805! Read in Lanczos vector normalization factor.
7806!
7807 CALL pio_netcdf_get_fvar (ng, model, dav(ng)%name, &
7808 & 'cg_QG', cg_qg, &
7809 & piofile = dav(ng)%pioFile, &
7810 & start = (/1,1/), &
7811 & total = (/ninner+1,outloop-1/))
7812 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7813!
7814! Read in reduction in the gradient norm.
7815!
7816 CALL pio_netcdf_get_fvar (ng, model, dav(ng)%name, &
7817 & 'cg_Greduc', cg_greduc, &
7818 & piofile = dav(ng)%pioFile, &
7819 & start = (/1,1/), &
7820 & total = (/ninner,outloop-1/))
7821 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7822!
7823! Read in tridiagonal matrix upper diagonal elements.
7824!
7825 CALL pio_netcdf_get_fvar (ng, model, dav(ng)%name, &
7826 & 'cg_zu', cg_zu, &
7827 & piofile = dav(ng)%pioFile, &
7828 & start = (/1,1/), &
7829 & total = (/ninner,outloop-1/))
7830 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7831!
7832! Read in eigenvalues of Lanczos recurrence relationship.
7833!
7834 CALL pio_netcdf_get_fvar (ng, model, dav(ng)%name, &
7835 & 'cg_Ritz', cg_ritz, &
7836 & piofile = dav(ng)%pioFile, &
7837 & start = (/1,1/), &
7838 & total = (/ninner,outloop-1/))
7839 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7840!
7841! Read eigenvalues relative error.
7842!
7843 CALL pio_netcdf_get_fvar (ng, model, dav(ng)%name, &
7844 & 'cg_RitzErr', cg_ritzerr, &
7845 & piofile = dav(ng)%pioFile, &
7846 & start = (/1,1/), &
7847 & total = (/ninner,outloop-1/))
7848 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7849!
7850! Read in eigenvectors of Lanczos recurrence relationship.
7851!
7852 CALL pio_netcdf_get_fvar (ng, model, dav(ng)%name, &
7853 & 'cg_zv', cg_zv, &
7854 & piofile = dav(ng)%pioFile, &
7855 & start = (/1,1/), &
7856 & total = (/ninner,ninner/))
7857 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7858!
7859 RETURN

References mod_fourdvar::cg_beta, mod_fourdvar::cg_delta, mod_fourdvar::cg_gamma, mod_fourdvar::cg_gnorm, mod_fourdvar::cg_greduc, mod_fourdvar::cg_qg, mod_fourdvar::cg_ritz, mod_fourdvar::cg_ritzerr, mod_fourdvar::cg_zu, mod_fourdvar::cg_zv, mod_iounits::dav, mod_scalars::exit_flag, strings_mod::founderror(), mod_fourdvar::nconvritz, mod_scalars::ninner, mod_scalars::noerror, mod_pio_netcdf::pio_netcdf_open(), mod_fourdvar::ritz, and mod_iounits::sourcefile.

Referenced by cg_read_cgradient().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ cg_write_cgradient()

subroutine, private cgradient_mod::cg_write_cgradient ( integer, intent(in) ng,
integer, intent(in) model,
integer, intent(in) innloop,
integer, intent(in) outloop )
private

Definition at line 7049 of file cgradient.F.

7050!***********************************************************************
7051! !
7052! This routine writes conjugate gradient vectors into 4DVAR NetCDF !
7053! for restart purposes. !
7054! !
7055!***********************************************************************
7056!
7057! Imported variable declarations
7058!
7059 integer, intent(in) :: ng, model, innLoop, outLoop
7060!
7061! Local variable declarations.
7062!
7063 integer :: status
7064!
7065 character (len=*), parameter :: MyFile = &
7066 & __FILE__//", cg_write_cgradient"
7067!
7068 sourcefile=myfile
7069!
7070!-----------------------------------------------------------------------
7071! Write out conjugate gradient variables.
7072!-----------------------------------------------------------------------
7073!
7074 SELECT CASE (dav(ng)%IOtype)
7075 CASE (io_nf90)
7076 CALL cg_write_cgradient_nf90 (ng, model, innloop, outloop)
7077
7078# if defined PIO_LIB && defined DISTRIBUTE
7079 CASE (io_pio)
7080 CALL cg_write_cgradient_pio (ng, model, innloop, outloop)
7081# endif
7082 CASE DEFAULT
7083 IF (master) WRITE (stdout,10) dav(ng)%IOtype
7084 exit_flag=3
7085 END SELECT
7086 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7087!
7088 10 FORMAT (' CG_WRITE_CGRADIENT - Illegal output file type,', &
7089 & ' io_type = ',i0, &
7090 & /,22x,'Check KeyWord ''OUT_LIB'' in ''roms.in''.')
7091!
7092 RETURN

References cg_write_cgradient_nf90(), cg_write_cgradient_pio(), mod_iounits::dav, mod_scalars::exit_flag, strings_mod::founderror(), mod_ncparam::io_nf90, mod_ncparam::io_pio, mod_parallel::master, mod_scalars::noerror, mod_iounits::sourcefile, and mod_iounits::stdout.

Referenced by cgradient_tile().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ cg_write_cgradient_nf90()

subroutine, private cgradient_mod::cg_write_cgradient_nf90 ( integer, intent(in) ng,
integer, intent(in) model,
integer, intent(in) innloop,
integer, intent(in) outloop )
private

Definition at line 7096 of file cgradient.F.

7097!***********************************************************************
7098!
7099! Imported variable declarations
7100!
7101 integer, intent(in) :: ng, model, innLoop, outLoop
7102!
7103! Local variable declarations.
7104!
7105 integer :: Nconv, status
7106!
7107 character (len=*), parameter :: MyFile = &
7108 & __FILE__//", cg_write_nf90"
7109!
7110 sourcefile=myfile
7111!
7112!-----------------------------------------------------------------------
7113! Write out conjugate gradient vectors.
7114!-----------------------------------------------------------------------
7115!
7116! Write out outer and inner iteration.
7117!
7118 CALL netcdf_put_ivar (ng, model, dav(ng)%name, &
7119 & 'outer', outer, &
7120 & (/0/), (/0/), &
7121 & ncid = dav(ng)%ncid)
7122 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7123
7124 CALL netcdf_put_ivar (ng, model, dav(ng)%name, &
7125 & 'inner', inner, &
7126 & (/0/), (/0/), &
7127 & ncid = dav(ng)%ncid)
7128 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7129!
7130! Write out number of converged Ritz eigenvalues.
7131!
7132 IF (innloop.eq.ninner) THEN
7133 CALL netcdf_put_ivar (ng, model, dav(ng)%name, &
7134 & 'nConvRitz', nconvritz, &
7135 & (/0/), (/0/), &
7136 & ncid = dav(ng)%ncid)
7137 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7138 END IF
7139!
7140! Write out converged Ritz eigenvalues.
7141!
7142 IF (innloop.eq.ninner) THEN
7143 nconv=max(1,nconvritz)
7144 CALL netcdf_put_fvar (ng, model, dav(ng)%name, &
7145 & 'Ritz', ritz(1:nconv), &
7146 & (/1/), (/nconv/), &
7147 & ncid = dav(ng)%ncid)
7148 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7149 END IF
7150!
7151! Write out conjugate gradient norms.
7152!
7153 IF (innloop.gt.0) THEN
7154 CALL netcdf_put_fvar (ng, model, dav(ng)%name, &
7155 & 'cg_beta', cg_beta, &
7156 & (/1,1/), (/ninner+1,nouter/), &
7157 & ncid = dav(ng)%ncid)
7158 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7159 END IF
7160!
7161! Write out Lanczos algorithm coefficients.
7162!
7163 IF (innloop.gt.0) THEN
7164 CALL netcdf_put_fvar (ng, model, dav(ng)%name, &
7165 & 'cg_delta', cg_delta, &
7166 & (/1,1/), (/ninner,nouter/), &
7167 & ncid = dav(ng)%ncid)
7168 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7169 END IF
7170!
7171 IF (innloop.gt.0) THEN
7172 CALL netcdf_put_fvar (ng, model, dav(ng)%name, &
7173 & 'cg_gamma', cg_gamma, &
7174 & (/1,1/), (/ninner,nouter/), &
7175 & ncid = dav(ng)%ncid)
7176 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7177 END IF
7178!
7179! Initial gradient normalization factor.
7180!
7181 IF (innloop.eq.0) THEN
7182 CALL netcdf_put_fvar (ng, model, dav(ng)%name, &
7183 & 'cg_Gnorm',cg_gnorm, &
7184 & (/1/), (/nouter/), &
7185 & ncid = dav(ng)%ncid)
7186 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7187 END IF
7188!
7189! Lanczos vector normalization factor.
7190!
7191 IF (innloop.gt.0) THEN
7192 CALL netcdf_put_fvar (ng, model, dav(ng)%name, &
7193 & 'cg_QG', cg_qg, &
7194 & (/1,1/), (/ninner,nouter/), &
7195 & ncid = dav(ng)%ncid)
7196 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7197 END IF
7198!
7199! Reduction in the gradient norm.
7200!
7201 IF (innloop.gt.0) THEN
7202 CALL netcdf_put_fvar (ng, model, dav(ng)%name, &
7203 & 'cg_Greduc', cg_greduc, &
7204 & (/1,1/), (/ninner,nouter/), &
7205 & ncid = dav(ng)%ncid)
7206 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7207 END IF
7208!
7209! Lanczos recurrence tridiagonal matrix.
7210!
7211 IF (innloop.gt.0) THEN
7212 CALL netcdf_put_fvar (ng, model, dav(ng)%name, &
7213 & 'cg_Tmatrix', cg_tmatrix, &
7214 & (/1,1/), (/ninner,3/), &
7215 & ncid = dav(ng)%ncid)
7216 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7217 END IF
7218!
7219! Lanczos tridiagonal matrix, upper diagonal elements.
7220!
7221 IF (innloop.gt.0) THEN
7222 CALL netcdf_put_fvar (ng, model, dav(ng)%name, &
7223 & 'cg_zu', cg_zu, &
7224 & (/1,1/), (/ninner,nouter/), &
7225 & ncid = dav(ng)%ncid)
7226 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7227 END IF
7228!
7229! Eigenvalues of Lanczos recurrence relationship.
7230!
7231 IF (innloop.gt.0) THEN
7232 CALL netcdf_put_fvar (ng, model, dav(ng)%name, &
7233 & 'cg_Ritz', cg_ritz, &
7234 & (/1,1/), (/ninner,nouter/), &
7235 & ncid = dav(ng)%ncid)
7236 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7237 END IF
7238!
7239! Eigenvalues relative error.
7240!
7241 IF (innloop.gt.0) THEN
7242 CALL netcdf_put_fvar (ng, model, dav(ng)%name, &
7243 & 'cg_RitzErr', cg_ritzerr, &
7244 & (/1,1/), (/ninner,nouter/), &
7245 & ncid = dav(ng)%ncid)
7246 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7247 END IF
7248!
7249! Eigenvectors of Lanczos recurrence relationship.
7250!
7251 IF (innloop.gt.0) THEN
7252 CALL netcdf_put_fvar (ng, model, dav(ng)%name, &
7253 & 'cg_zv', cg_zv, &
7254 & (/1,1/), (/ninner,ninner/), &
7255 & ncid = dav(ng)%ncid)
7256 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7257 END IF
7258!
7259! Write out Lanczos algorithm coefficients into Lanczos vectors
7260! output file (for now adjoint history file). These coefficients
7261! can be used for preconditioning or to compute the sensitivity
7262! of the observations to the 4DVAR data assimilation system.
7263!
7264 IF (innloop.gt.0) THEN
7265 CALL netcdf_put_fvar (ng, model, adm(ng)%name, &
7266 & 'cg_beta', cg_beta, &
7267 & (/1,1/), (/ninner+1,nouter/), &
7268 & ncid = adm(ng)%ncid)
7269 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7270!
7271 CALL netcdf_put_fvar (ng, model, adm(ng)%name, &
7272 & 'cg_delta', cg_delta, &
7273 & (/1,1/), (/ninner,nouter/), &
7274 & ncid = adm(ng)%ncid)
7275 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7276!
7277 CALL netcdf_put_fvar (ng, model, adm(ng)%name, &
7278 & 'cg_zv', cg_zv, &
7279 & (/1,1/), (/ninner,ninner/), &
7280 & ncid = adm(ng)%ncid)
7281 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7282
7283# ifdef EVOLVED_LCZ
7284 CALL netcdf_put_fvar (ng, model, hss(ng)%name, &
7285 & 'cg_beta', cg_beta, &
7286 & (/1,1/), (/ninner+1,nouter/), &
7287 & ncid = hss(ng)%ncid)
7288 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7289!
7290 CALL netcdf_put_fvar (ng, model, hss(ng)%name, &
7291 & 'cg_delta', cg_delta, &
7292 & (/1,1/), (/ninner,nouter/), &
7293 & ncid = hss(ng)%ncid)
7294 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7295!
7296 CALL netcdf_put_fvar (ng, model, hss(ng)%name, &
7297 & 'cg_zv', cg_zv, &
7298 & (/1,1/), (/ninner,ninner/), &
7299 & ncid = hss(ng)%ncid)
7300 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7301# endif
7302 END IF
7303!
7304!-----------------------------------------------------------------------
7305! Synchronize model/observation NetCDF file to disk.
7306!-----------------------------------------------------------------------
7307!
7308 CALL netcdf_sync (ng, model, dav(ng)%name, dav(ng)%ncid)
7309!
7310 RETURN

References mod_iounits::adm, mod_fourdvar::cg_beta, mod_fourdvar::cg_delta, mod_fourdvar::cg_gamma, mod_fourdvar::cg_gnorm, mod_fourdvar::cg_greduc, mod_fourdvar::cg_qg, mod_fourdvar::cg_ritz, mod_fourdvar::cg_ritzerr, mod_fourdvar::cg_tmatrix, mod_fourdvar::cg_zu, mod_fourdvar::cg_zv, mod_iounits::dav, mod_scalars::exit_flag, strings_mod::founderror(), mod_iounits::hss, mod_scalars::inner, mod_scalars::nconv, mod_fourdvar::nconvritz, mod_netcdf::netcdf_sync(), mod_scalars::ninner, mod_scalars::noerror, mod_scalars::nouter, mod_scalars::outer, mod_fourdvar::ritz, and mod_iounits::sourcefile.

Referenced by cg_write_cgradient().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ cg_write_cgradient_pio()

subroutine, private cgradient_mod::cg_write_cgradient_pio ( integer, intent(in) ng,
integer, intent(in) model,
integer, intent(in) innloop,
integer, intent(in) outloop )
private

Definition at line 7316 of file cgradient.F.

7317!***********************************************************************
7318!
7319! Imported variable declarations
7320!
7321 integer, intent(in) :: ng, model, innLoop, outLoop
7322!
7323! Local variable declarations.
7324!
7325 integer :: Nconv, status
7326!
7327 character (len=*), parameter :: MyFile = &
7328 & __FILE__//", cg_write_pio"
7329!
7330 sourcefile=myfile
7331!
7332!-----------------------------------------------------------------------
7333! Write out conjugate gradient vectors.
7334!-----------------------------------------------------------------------
7335!
7336! Write out outer and inner iteration.
7337!
7338 CALL pio_netcdf_put_ivar (ng, model, dav(ng)%name, &
7339 & 'outer', outer, &
7340 & (/0/), (/0/), &
7341 & piofile = dav(ng)%pioFile)
7342 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7343
7344 CALL pio_netcdf_put_ivar (ng, model, dav(ng)%name, &
7345 & 'inner', inner, &
7346 & (/0/), (/0/), &
7347 & piofile = dav(ng)%pioFile)
7348 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7349!
7350! Write out number of converged Ritz eigenvalues.
7351!
7352 IF (innloop.eq.ninner) THEN
7353 CALL pio_netcdf_put_ivar (ng, model, dav(ng)%name, &
7354 & 'nConvRitz', nconvritz, &
7355 & (/0/), (/0/), &
7356 & piofile = dav(ng)%pioFile)
7357 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7358 END IF
7359!
7360! Write out converged Ritz eigenvalues.
7361!
7362 IF (innloop.eq.ninner) THEN
7363 nconv=max(1,nconvritz)
7364 CALL pio_netcdf_put_fvar (ng, model, dav(ng)%name, &
7365 & 'Ritz', ritz(1:nconv), &
7366 & (/1/), (/nconv/), &
7367 & piofile = dav(ng)%pioFile)
7368 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7369 END IF
7370!
7371! Write out conjugate gradient norms.
7372!
7373 IF (innloop.gt.0) THEN
7374 CALL pio_netcdf_put_fvar (ng, model, dav(ng)%name, &
7375 & 'cg_beta', cg_beta, &
7376 & (/1,1/), (/ninner+1,nouter/), &
7377 & piofile = dav(ng)%pioFile)
7378 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7379 END IF
7380!
7381! Write out Lanczos algorithm coefficients.
7382!
7383 IF (innloop.gt.0) THEN
7384 CALL pio_netcdf_put_fvar (ng, model, dav(ng)%name, &
7385 & 'cg_delta', cg_delta, &
7386 & (/1,1/), (/ninner,nouter/), &
7387 & piofile = dav(ng)%pioFile)
7388 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7389 END IF
7390!
7391 IF (innloop.gt.0) THEN
7392 CALL pio_netcdf_put_fvar (ng, model, dav(ng)%name, &
7393 & 'cg_gamma', cg_gamma, &
7394 & (/1,1/), (/ninner,nouter/), &
7395 & piofile = dav(ng)%pioFile)
7396 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7397 END IF
7398!
7399! Initial gradient normalization factor.
7400!
7401 IF (innloop.eq.0) THEN
7402 CALL pio_netcdf_put_fvar (ng, model, dav(ng)%name, &
7403 & 'cg_Gnorm',cg_gnorm, &
7404 & (/1/), (/nouter/), &
7405 & piofile = dav(ng)%pioFile)
7406 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7407 END IF
7408!
7409! Lanczos vector normalization factor.
7410!
7411 IF (innloop.gt.0) THEN
7412 CALL pio_netcdf_put_fvar (ng, model, dav(ng)%name, &
7413 & 'cg_QG', cg_qg, &
7414 & (/1,1/), (/ninner,nouter/), &
7415 & piofile = dav(ng)%pioFile)
7416 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7417 END IF
7418!
7419! Reduction in the gradient norm.
7420!
7421 IF (innloop.gt.0) THEN
7422 CALL pio_netcdf_put_fvar (ng, model, dav(ng)%name, &
7423 & 'cg_Greduc', cg_greduc, &
7424 & (/1,1/), (/ninner,nouter/), &
7425 & piofile = dav(ng)%pioFile)
7426 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7427 END IF
7428!
7429! Lanczos recurrence tridiagonal matrix.
7430!
7431 IF (innloop.gt.0) THEN
7432 CALL pio_netcdf_put_fvar (ng, model, dav(ng)%name, &
7433 & 'cg_Tmatrix', cg_tmatrix, &
7434 & (/1,1/), (/ninner,3/), &
7435 & piofile = dav(ng)%pioFile)
7436 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7437 END IF
7438!
7439! Lanczos tridiagonal matrix, upper diagonal elements.
7440!
7441 IF (innloop.gt.0) THEN
7442 CALL pio_netcdf_put_fvar (ng, model, dav(ng)%name, &
7443 & 'cg_zu', cg_zu, &
7444 & (/1,1/), (/ninner,nouter/), &
7445 & piofile = dav(ng)%pioFile)
7446 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7447 END IF
7448!
7449! Eigenvalues of Lanczos recurrence relationship.
7450!
7451 IF (innloop.gt.0) THEN
7452 CALL pio_netcdf_put_fvar (ng, model, dav(ng)%name, &
7453 & 'cg_Ritz', cg_ritz, &
7454 & (/1,1/), (/ninner,nouter/), &
7455 & piofile = dav(ng)%pioFile)
7456 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7457 END IF
7458!
7459! Eigenvalues relative error.
7460!
7461 IF (innloop.gt.0) THEN
7462 CALL pio_netcdf_put_fvar (ng, model, dav(ng)%name, &
7463 & 'cg_RitzErr', cg_ritzerr, &
7464 & (/1,1/), (/ninner,nouter/), &
7465 & piofile = dav(ng)%pioFile)
7466 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7467 END IF
7468!
7469! Eigenvectors of Lanczos recurrence relationship.
7470!
7471 IF (innloop.gt.0) THEN
7472 CALL pio_netcdf_put_fvar (ng, model, dav(ng)%name, &
7473 & 'cg_zv', cg_zv, &
7474 & (/1,1/), (/ninner,ninner/), &
7475 & piofile = dav(ng)%pioFile)
7476 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7477 END IF
7478!
7479! Write out Lanczos algorithm coefficients into Lanczos vectors
7480! output file (for now adjoint history file). These coefficients
7481! can be used for preconditioning or to compute the sensitivity
7482! of the observations to the 4DVAR data assimilation system.
7483!
7484 IF (innloop.gt.0) THEN
7485 CALL pio_netcdf_put_fvar (ng, model, adm(ng)%name, &
7486 & 'cg_beta', cg_beta, &
7487 & (/1,1/), (/ninner+1,nouter/), &
7488 & piofile = adm(ng)%pioFile)
7489 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7490!
7491 CALL pio_netcdf_put_fvar (ng, model, adm(ng)%name, &
7492 & 'cg_delta', cg_delta, &
7493 & (/1,1/), (/ninner,nouter/), &
7494 & piofile = adm(ng)%pioFile)
7495 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7496!
7497 CALL pio_netcdf_put_fvar (ng, model, adm(ng)%name, &
7498 & 'cg_zv', cg_zv, &
7499 & (/1,1/), (/ninner,ninner/), &
7500 & piofile = adm(ng)%pioFile)
7501 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7502
7503# ifdef EVOLVED_LCZ
7504 CALL pio_netcdf_put_fvar (ng, model, hss(ng)%name, &
7505 & 'cg_beta', cg_beta, &
7506 & (/1,1/), (/ninner+1,nouter/), &
7507 & piofile = hss(ng)%pioFile)
7508 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7509!
7510 CALL pio_netcdf_put_fvar (ng, model, hss(ng)%name, &
7511 & 'cg_delta', cg_delta, &
7512 & (/1,1/), (/ninner,nouter/), &
7513 & piofile = hss(ng)%pioFile)
7514 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7515!
7516 CALL pio_netcdf_put_fvar (ng, model, hss(ng)%name, &
7517 & 'cg_zv', cg_zv, &
7518 & (/1,1/), (/ninner,ninner/), &
7519 & piofile = hss(ng)%pioFile)
7520 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7521# endif
7522 END IF
7523!
7524!-----------------------------------------------------------------------
7525! Synchronize model/observation NetCDF file to disk.
7526!-----------------------------------------------------------------------
7527!
7528 CALL pio_netcdf_sync (ng, model, dav(ng)%name, dav(ng)%pioFile)
7529!
7530 RETURN

References mod_iounits::adm, mod_fourdvar::cg_beta, mod_fourdvar::cg_delta, mod_fourdvar::cg_gamma, mod_fourdvar::cg_gnorm, mod_fourdvar::cg_greduc, mod_fourdvar::cg_qg, mod_fourdvar::cg_ritz, mod_fourdvar::cg_ritzerr, mod_fourdvar::cg_tmatrix, mod_fourdvar::cg_zu, mod_fourdvar::cg_zv, mod_iounits::dav, mod_scalars::exit_flag, strings_mod::founderror(), mod_iounits::hss, mod_scalars::inner, mod_scalars::nconv, mod_fourdvar::nconvritz, mod_scalars::ninner, mod_scalars::noerror, mod_scalars::nouter, mod_scalars::outer, mod_pio_netcdf::pio_netcdf_sync(), mod_fourdvar::ritz, and mod_iounits::sourcefile.

Referenced by cg_write_cgradient().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ cgradient()

subroutine, public cgradient_mod::cgradient ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) model,
integer, intent(in) innloop,
integer, intent(in) outloop )

Definition at line 204 of file cgradient.F.

205!***********************************************************************
206!
207! Imported variable declarations.
208!
209 integer, intent(in) :: ng, tile, model, innLoop, outLoop
210!
211! Local variable declarations.
212!
213 character (len=*), parameter :: MyFile = &
214 & __FILE__
215!
216# include "tile.h"
217!
218# ifdef PROFILE
219 CALL wclock_on (ng, model, 85, __line__, myfile)
220# endif
221 CALL cgradient_tile (ng, tile, model, &
222 & lbi, ubi, lbj, ubj, lbij, ubij, &
223 & imins, imaxs, jmins, jmaxs, &
224 & lold(ng), lnew(ng), &
225 & innloop, outloop, &
226# ifdef MASKING
227 & grid(ng) % rmask, &
228 & grid(ng) % umask, &
229 & grid(ng) % vmask, &
230# endif
231# ifdef ADJUST_BOUNDARY
232# ifdef SOLVE3D
233 & boundary(ng) % t_obc, &
234 & boundary(ng) % u_obc, &
235 & boundary(ng) % v_obc, &
236# endif
237 & boundary(ng) % ubar_obc, &
238 & boundary(ng) % vbar_obc, &
239 & boundary(ng) % zeta_obc, &
240# endif
241# ifdef ADJUST_WSTRESS
242 & forces(ng) % ustr, &
243 & forces(ng) % vstr, &
244# endif
245# ifdef SOLVE3D
246# ifdef ADJUST_STFLUX
247 & forces(ng) % tflux, &
248# endif
249 & ocean(ng) % t, &
250 & ocean(ng) % u, &
251 & ocean(ng) % v, &
252# else
253 & ocean(ng) % ubar, &
254 & ocean(ng) % vbar, &
255# endif
256 & ocean(ng) % zeta, &
257# ifdef ADJUST_BOUNDARY
258# ifdef SOLVE3D
259 & boundary(ng) % tl_t_obc, &
260 & boundary(ng) % tl_u_obc, &
261 & boundary(ng) % tl_v_obc, &
262# endif
263 & boundary(ng) % tl_ubar_obc, &
264 & boundary(ng) % tl_vbar_obc, &
265 & boundary(ng) % tl_zeta_obc, &
266# endif
267# ifdef ADJUST_WSTRESS
268 & forces(ng) % tl_ustr, &
269 & forces(ng) % tl_vstr, &
270# endif
271# ifdef SOLVE3D
272# ifdef ADJUST_STFLUX
273 & forces(ng) % tl_tflux, &
274# endif
275 & ocean(ng) % tl_t, &
276 & ocean(ng) % tl_u, &
277 & ocean(ng) % tl_v, &
278# else
279 & ocean(ng) % tl_ubar, &
280 & ocean(ng) % tl_vbar, &
281# endif
282 & ocean(ng) % tl_zeta, &
283# ifdef ADJUST_BOUNDARY
284# ifdef SOLVE3D
285 & boundary(ng) % d_t_obc, &
286 & boundary(ng) % d_u_obc, &
287 & boundary(ng) % d_v_obc, &
288# endif
289 & boundary(ng) % d_ubar_obc, &
290 & boundary(ng) % d_vbar_obc, &
291 & boundary(ng) % d_zeta_obc, &
292# endif
293# ifdef ADJUST_WSTRESS
294 & forces(ng) % d_sustr, &
295 & forces(ng) % d_svstr, &
296# endif
297# ifdef SOLVE3D
298# ifdef ADJUST_STFLUX
299 & forces(ng) % d_stflx, &
300# endif
301 & ocean(ng) % d_t, &
302 & ocean(ng) % d_u, &
303 & ocean(ng) % d_v, &
304# else
305 & ocean(ng) % d_ubar, &
306 & ocean(ng) % d_vbar, &
307# endif
308 & ocean(ng) % d_zeta, &
309# ifdef ADJUST_BOUNDARY
310# ifdef SOLVE3D
311 & boundary(ng) % ad_t_obc, &
312 & boundary(ng) % ad_u_obc, &
313 & boundary(ng) % ad_v_obc, &
314# endif
315 & boundary(ng) % ad_ubar_obc, &
316 & boundary(ng) % ad_vbar_obc, &
317 & boundary(ng) % ad_zeta_obc, &
318# endif
319# ifdef ADJUST_WSTRESS
320 & forces(ng) % ad_ustr, &
321 & forces(ng) % ad_vstr, &
322# endif
323# ifdef SOLVE3D
324# ifdef ADJUST_STFLUX
325 & forces(ng) % ad_tflux, &
326# endif
327 & ocean(ng) % ad_t, &
328 & ocean(ng) % ad_u, &
329 & ocean(ng) % ad_v, &
330# else
331 & ocean(ng) % ad_ubar, &
332 & ocean(ng) % ad_vbar, &
333# endif
334 & ocean(ng) % ad_zeta)
335# ifdef PROFILE
336 CALL wclock_off (ng, model, 85, __line__, myfile)
337# endif
338!
339 RETURN
wclock_off
recursive subroutine wclock_off(ng, model, region, line, routine)
Definition timers.F:148
wclock_on
recursive subroutine wclock_on(ng, model, region, line, routine)
Definition timers.F:3

References mod_boundary::boundary, cgradient_tile(), mod_forces::forces, mod_grid::grid, mod_stepping::lnew, mod_stepping::lold, mod_ocean::ocean, wclock_off(), and wclock_on().

Referenced by i4dvar_mod::increment().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ cgradient_tile()

subroutine, private cgradient_mod::cgradient_tile ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) model,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
integer, intent(in) lbij,
integer, intent(in) ubij,
integer, intent(in) imins,
integer, intent(in) imaxs,
integer, intent(in) jmins,
integer, intent(in) jmaxs,
integer, intent(in) lold,
integer, intent(in) lnew,
integer, intent(in) innloop,
integer, intent(in) outloop,
real(r8), dimension(lbi:,lbj:), intent(in) rmask,
real(r8), dimension(lbi:,lbj:), intent(in) umask,
real(r8), dimension(lbi:,lbj:), intent(in) vmask,
real(r8), dimension(lbij:,:,:,:,:,:), intent(inout) nl_t_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) nl_u_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) nl_v_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) nl_ubar_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) nl_vbar_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) nl_zeta_obc,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) nl_ustr,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) nl_vstr,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) nl_tflux,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) nl_t,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) nl_u,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) nl_v,
real(r8), dimension(lbi:,lbj:,:), intent(inout) nl_zeta,
real(r8), dimension(lbij:,:,:,:,:,:), intent(inout) tl_t_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) tl_u_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) tl_v_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) tl_ubar_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) tl_vbar_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) tl_zeta_obc,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) tl_ustr,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) tl_vstr,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) tl_tflux,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) tl_t,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) tl_u,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) tl_v,
real(r8), dimension(lbi:,lbj:,:), intent(inout) tl_zeta,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) d_t_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) d_u_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) d_v_obc,
real(r8), dimension(lbij:,:,:), intent(inout) d_ubar_obc,
real(r8), dimension(lbij:,:,:), intent(inout) d_vbar_obc,
real(r8), dimension(lbij:,:,:), intent(inout) d_zeta_obc,
real(r8), dimension(lbi:,lbj:,:), intent(inout) d_sustr,
real(r8), dimension(lbi:,lbj:,:), intent(inout) d_svstr,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) d_stflx,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) d_t,
real(r8), dimension(lbi:,lbj:,:), intent(inout) d_u,
real(r8), dimension(lbi:,lbj:,:), intent(inout) d_v,
real(r8), dimension(lbi:,lbj:), intent(inout) d_zeta,
real(r8), dimension(lbij:,:,:,:,:,:), intent(inout) ad_t_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) ad_u_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) ad_v_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) ad_ubar_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) ad_vbar_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) ad_zeta_obc,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) ad_ustr,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) ad_vstr,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) ad_tflux,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) ad_t,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) ad_u,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) ad_v,
real(r8), dimension(lbi:,lbj:,:), intent(inout) ad_zeta )
private

Definition at line 343 of file cgradient.F.

427!***********************************************************************
428!
429! Imported variable declarations.
430!
431 integer, intent(in) :: ng, tile, model
432 integer, intent(in) :: LBi, UBi, LBj, UBj, LBij, UBij
433 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
434 integer, intent(in) :: Lold, Lnew
435 integer, intent(in) :: innLoop, outLoop
436!
437# ifdef ASSUMED_SHAPE
438# ifdef MASKING
439 real(r8), intent(in) :: rmask(LBi:,LBj:)
440 real(r8), intent(in) :: umask(LBi:,LBj:)
441 real(r8), intent(in) :: vmask(LBi:,LBj:)
442# endif
443# ifdef ADJUST_BOUNDARY
444# ifdef SOLVE3D
445 real(r8), intent(inout) :: ad_t_obc(LBij:,:,:,:,:,:)
446 real(r8), intent(inout) :: ad_u_obc(LBij:,:,:,:,:)
447 real(r8), intent(inout) :: ad_v_obc(LBij:,:,:,:,:)
448# endif
449 real(r8), intent(inout) :: ad_ubar_obc(LBij:,:,:,:)
450 real(r8), intent(inout) :: ad_vbar_obc(LBij:,:,:,:)
451 real(r8), intent(inout) :: ad_zeta_obc(LBij:,:,:,:)
452# endif
453# ifdef ADJUST_WSTRESS
454 real(r8), intent(inout) :: ad_ustr(LBi:,LBj:,:,:)
455 real(r8), intent(inout) :: ad_vstr(LBi:,LBj:,:,:)
456# endif
457# ifdef SOLVE3D
458# ifdef ADJUST_STFLUX
459 real(r8), intent(inout) :: ad_tflux(LBi:,LBj:,:,:,:)
460# endif
461 real(r8), intent(inout) :: ad_t(LBi:,LBj:,:,:,:)
462 real(r8), intent(inout) :: ad_u(LBi:,LBj:,:,:)
463 real(r8), intent(inout) :: ad_v(LBi:,LBj:,:,:)
464# else
465 real(r8), intent(inout) :: ad_ubar(LBi:,LBj:,:)
466 real(r8), intent(inout) :: ad_vbar(LBi:,LBj:,:)
467# endif
468 real(r8), intent(inout) :: ad_zeta(LBi:,LBj:,:)
469# ifdef ADJUST_BOUNDARY
470# ifdef SOLVE3D
471 real(r8), intent(inout) :: d_t_obc(LBij:,:,:,:,:)
472 real(r8), intent(inout) :: d_u_obc(LBij:,:,:,:)
473 real(r8), intent(inout) :: d_v_obc(LBij:,:,:,:)
474# endif
475 real(r8), intent(inout) :: d_ubar_obc(LBij:,:,:)
476 real(r8), intent(inout) :: d_vbar_obc(LBij:,:,:)
477 real(r8), intent(inout) :: d_zeta_obc(LBij:,:,:)
478# endif
479# ifdef ADJUST_WSTRESS
480 real(r8), intent(inout) :: d_sustr(LBi:,LBj:,:)
481 real(r8), intent(inout) :: d_svstr(LBi:,LBj:,:)
482# endif
483# ifdef SOLVE3D
484# ifdef ADJUST_STFLUX
485 real(r8), intent(inout) :: d_stflx(LBi:,LBj:,:,:)
486# endif
487 real(r8), intent(inout) :: d_t(LBi:,LBj:,:,:)
488 real(r8), intent(inout) :: d_u(LBi:,LBj:,:)
489 real(r8), intent(inout) :: d_v(LBi:,LBj:,:)
490# else
491 real(r8), intent(inout) :: d_ubar(LBi:,LBj:)
492 real(r8), intent(inout) :: d_vbar(LBi:,LBj:)
493# endif
494 real(r8), intent(inout) :: d_zeta(LBi:,LBj:)
495# ifdef ADJUST_BOUNDARY
496# ifdef SOLVE3D
497 real(r8), intent(inout) :: nl_t_obc(LBij:,:,:,:,:,:)
498 real(r8), intent(inout) :: nl_u_obc(LBij:,:,:,:,:)
499 real(r8), intent(inout) :: nl_v_obc(LBij:,:,:,:,:)
500# endif
501 real(r8), intent(inout) :: nl_ubar_obc(LBij:,:,:,:)
502 real(r8), intent(inout) :: nl_vbar_obc(LBij:,:,:,:)
503 real(r8), intent(inout) :: nl_zeta_obc(LBij:,:,:,:)
504# endif
505# ifdef ADJUST_WSTRESS
506 real(r8), intent(inout) :: nl_ustr(LBi:,LBj:,:,:)
507 real(r8), intent(inout) :: nl_vstr(LBi:,LBj:,:,:)
508# endif
509# ifdef SOLVE3D
510# ifdef ADJUST_STFLUX
511 real(r8), intent(inout) :: nl_tflux(LBi:,LBj:,:,:,:)
512# endif
513 real(r8), intent(inout) :: nl_t(LBi:,LBj:,:,:,:)
514 real(r8), intent(inout) :: nl_u(LBi:,LBj:,:,:)
515 real(r8), intent(inout) :: nl_v(LBi:,LBj:,:,:)
516# else
517 real(r8), intent(inout) :: nl_ubar(LBi:,LBj:,:)
518 real(r8), intent(inout) :: nl_vbar(LBi:,LBj:,:)
519# endif
520 real(r8), intent(inout) :: nl_zeta(LBi:,LBj:,:)
521# ifdef ADJUST_BOUNDARY
522# ifdef SOLVE3D
523 real(r8), intent(inout) :: tl_t_obc(LBij:,:,:,:,:,:)
524 real(r8), intent(inout) :: tl_u_obc(LBij:,:,:,:,:)
525 real(r8), intent(inout) :: tl_v_obc(LBij:,:,:,:,:)
526# endif
527 real(r8), intent(inout) :: tl_ubar_obc(LBij:,:,:,:)
528 real(r8), intent(inout) :: tl_vbar_obc(LBij:,:,:,:)
529 real(r8), intent(inout) :: tl_zeta_obc(LBij:,:,:,:)
530# endif
531# ifdef ADJUST_WSTRESS
532 real(r8), intent(inout) :: tl_ustr(LBi:,LBj:,:,:)
533 real(r8), intent(inout) :: tl_vstr(LBi:,LBj:,:,:)
534# endif
535# ifdef SOLVE3D
536# ifdef ADJUST_STFLUX
537 real(r8), intent(inout) :: tl_tflux(LBi:,LBj:,:,:,:)
538# endif
539 real(r8), intent(inout) :: tl_t(LBi:,LBj:,:,:,:)
540 real(r8), intent(inout) :: tl_u(LBi:,LBj:,:,:)
541 real(r8), intent(inout) :: tl_v(LBi:,LBj:,:,:)
542# else
543 real(r8), intent(inout) :: tl_ubar(LBi:,LBj:,:)
544 real(r8), intent(inout) :: tl_vbar(LBi:,LBj:,:)
545# endif
546 real(r8), intent(inout) :: tl_zeta(LBi:,LBj:,:)
547
548# else
549
550# ifdef MASKING
551 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
552 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
553 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
554# endif
555# ifdef ADJUST_BOUNDARY
556# ifdef SOLVE3D
557 real(r8), intent(inout) :: ad_t_obc(LBij:UBij,N(ng),4, &
558 & Nbrec(ng),2,NT(ng))
559 real(r8), intent(inout) :: ad_u_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
560 real(r8), intent(inout) :: ad_v_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
561# endif
562 real(r8), intent(inout) :: ad_ubar_obc(LBij:UBij,4,Nbrec(ng),2)
563 real(r8), intent(inout) :: ad_vbar_obc(LBij:UBij,4,Nbrec(ng),2)
564 real(r8), intent(inout) :: ad_zeta_obc(LBij:UBij,4,Nbrec(ng),2)
565# endif
566# ifdef ADJUST_WSTRESS
567 real(r8), intent(inout) :: ad_ustr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
568 real(r8), intent(inout) :: ad_vstr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
569# endif
570# ifdef SOLVE3D
571# ifdef ADJUST_STFLUX
572 real(r8), intent(inout) :: ad_tflux(LBi:UBi,LBj:UBj, &
573 & Nfrec(ng),2,NT(ng))
574# endif
575 real(r8), intent(inout) :: ad_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
576 real(r8), intent(inout) :: ad_u(LBi:UBi,LBj:UBj,N(ng),2)
577 real(r8), intent(inout) :: ad_v(LBi:UBi,LBj:UBj,N(ng),2)
578# else
579 real(r8), intent(inout) :: ad_ubar(LBi:UBi,LBj:UBj,:)
580 real(r8), intent(inout) :: ad_vbar(LBi:UBi,LBj:UBj,:)
581# endif
582 real(r8), intent(inout) :: ad_zeta(LBi:UBi,LBj:UBj,:)
583# ifdef ADJUST_BOUNDARY
584# ifdef SOLVE3D
585 real(r8), intent(inout) :: d_t_obc(LBij:UBij,N(ng),4, &
586 & Nbrec(ng),NT(ng))
587 real(r8), intent(inout) :: d_u_obc(LBij:UBij,N(ng),4,Nbrec(ng))
588 real(r8), intent(inout) :: d_v_obc(LBij:UBij,N(ng),4,Nbrec(ng))
589# endif
590 real(r8), intent(inout) :: d_ubar_obc(LBij:UBij,4,Nbrec(ng))
591 real(r8), intent(inout) :: d_vbar_obc(LBij:UBij,4,Nbrec(ng))
592 real(r8), intent(inout) :: d_zeta_obc(LBij:UBij,4,Nbrec(ng))
593# endif
594# ifdef ADJUST_WSTRESS
595 real(r8), intent(inout) :: d_sustr(LBi:UBi,LBj:UBj,Nfrec(ng))
596 real(r8), intent(inout) :: d_svstr(LBi:UBi,LBj:UBj,Nfrec(ng))
597# endif
598# ifdef SOLVE3D
599# ifdef ADJUST_STFLUX
600 real(r8), intent(inout) :: d_stflx(LBi:UBi,LBj:UBj, &
601 & Nfrec(ng),NT(ng))
602# endif
603 real(r8), intent(inout) :: d_t(LBi:UBi,LBj:UBj,N(ng),NT(ng))
604 real(r8), intent(inout) :: d_u(LBi:UBi,LBj:UBj,N(ng))
605 real(r8), intent(inout) :: d_v(LBi:UBi,LBj:UBj,N(ng))
606# else
607 real(r8), intent(inout) :: d_ubar(LBi:UBi,LBj:UBj)
608 real(r8), intent(inout) :: d_vbar(LBi:UBi,LBj:UBj)
609# endif
610 real(r8), intent(inout) :: d_zeta(LBi:UBi,LBj:UBj)
611# ifdef ADJUST_BOUNDARY
612# ifdef SOLVE3D
613 real(r8), intent(inout) :: nl_t_obc(LBij:UBij,N(ng),4, &
614 & Nbrec(ng),2,NT(ng))
615 real(r8), intent(inout) :: nl_u_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
616 real(r8), intent(inout) :: nl_v_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
617# endif
618 real(r8), intent(inout) :: nl_ubar_obc(LBij:UBij,4,Nbrec(ng),2)
619 real(r8), intent(inout) :: nl_vbar_obc(LBij:UBij,4,Nbrec(ng),2)
620 real(r8), intent(inout) :: nl_zeta_obc(LBij:UBij,4,Nbrec(ng),2)
621# endif
622# ifdef ADJUST_WSTRESS
623 real(r8), intent(inout) :: nl_ustr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
624 real(r8), intent(inout) :: nl_vstr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
625# endif
626# ifdef SOLVE3D
627# ifdef ADJUST_STFLUX
628 real(r8), intent(inout) :: nl_tflux(LBi:UBi,LBj:UBj, &
629 & Nfrec(ng),2,NT(ng))
630# endif
631 real(r8), intent(inout) :: nl_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
632 real(r8), intent(inout) :: nl_u(LBi:UBi,LBj:UBj,N(ng),2)
633 real(r8), intent(inout) :: nl_v(LBi:UBi,LBj:UBj,N(ng),2)
634# else
635 real(r8), intent(inout) :: nl_ubar(LBi:UBi,LBj:UBj,:)
636 real(r8), intent(inout) :: nl_vbar(LBi:UBi,LBj:UBj,:)
637# endif
638 real(r8), intent(inout) :: nl_zeta(LBi:UBi,LBj:UBj,:)
639# ifdef ADJUST_BOUNDARY
640# ifdef SOLVE3D
641 real(r8), intent(inout) :: tl_t_obc(LBij:UBij,N(ng),4, &
642 & Nbrec(ng),2,NT(ng))
643 real(r8), intent(inout) :: tl_u_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
644 real(r8), intent(inout) :: tl_v_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
645# endif
646 real(r8), intent(inout) :: tl_ubar_obc(LBij:UBij,4,Nbrec(ng),2)
647 real(r8), intent(inout) :: tl_vbar_obc(LBij:UBij,4,Nbrec(ng),2)
648 real(r8), intent(inout) :: tl_zeta_obc(LBij:UBij,4,Nbrec(ng),2)
649# endif
650# ifdef ADJUST_WSTRESS
651 real(r8), intent(inout) :: tl_ustr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
652 real(r8), intent(inout) :: tl_vstr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
653# endif
654# ifdef SOLVE3D
655# ifdef ADJUST_STFLUX
656 real(r8), intent(inout) :: tl_tflux(LBi:UBi,LBj:UBj, &
657 & Nfrec(ng),2,NT(ng))
658# endif
659 real(r8), intent(inout) :: tl_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
660 real(r8), intent(inout) :: tl_u(LBi:UBi,LBj:UBj,N(ng),2)
661 real(r8), intent(inout) :: tl_v(LBi:UBi,LBj:UBj,N(ng),2)
662# else
663 real(r8), intent(inout) :: tl_ubar(LBi:UBi,LBj:UBj,:)
664 real(r8), intent(inout) :: tl_vbar(LBi:UBi,LBj:UBj,:)
665# endif
666 real(r8), intent(inout) :: tl_zeta(LBi:UBi,LBj:UBj,:)
667# endif
668!
669! Local variable declarations.
670!
671 logical :: Ltrans
672!
673 integer :: L1 = 1
674 integer :: L2 = 2
675
676 integer :: Linp, Lout, Lscale, Lwrk, Lwrk1, i, j, ic
677 integer :: info, itheta1
678!
679 real(dp) :: norm, zbeta, ztheta1
680
681 real(dp), dimension(2*Ninner-2) :: work
682!
683 character (len=13) :: string
684
685 character (len=*), parameter :: MyFile = &
686 & __FILE__//", cgradient_tile"
687
688# include "set_bounds.h"
689!
690!-----------------------------------------------------------------------
691! Initialize trial step size.
692!-----------------------------------------------------------------------
693!
694 ritzmaxerr=hevecerr
695 ltrans=.false.
696!
697 IF (master) WRITE (stdout,10)
698 10 FORMAT (/,' <<<< Conjugate Gradient Algorithm >>>>',/)
699!
700! If preconditioning, convert the total gradient ad_var(L2)
701! from v-space to y-space.
702!
703 IF (lprecond.and.(outloop.gt.1)) THEN
704
705 lscale=2 ! SQRT spectral LMP
706 ltrans=.true.
707!
708! Copy ad_var(L2) into nl_var(L1)
709!
710 CALL state_copy (ng, tile, &
711 & lbi, ubi, lbj, ubj, lbij, ubij, &
712 & l2, l1, &
713# ifdef ADJUST_BOUNDARY
714# ifdef SOLVE3D
715 & nl_t_obc, ad_t_obc, &
716 & nl_u_obc, ad_u_obc, &
717 & nl_v_obc, ad_v_obc, &
718# endif
719 & nl_ubar_obc, ad_ubar_obc, &
720 & nl_vbar_obc, ad_vbar_obc, &
721 & nl_zeta_obc, ad_zeta_obc, &
722# endif
723# ifdef ADJUST_WSTRESS
724 & nl_ustr, ad_ustr, &
725 & nl_vstr, ad_vstr, &
726# endif
727# ifdef SOLVE3D
728# ifdef ADJUST_STFLUX
729 & nl_tflux, ad_tflux, &
730# endif
731 & nl_t, ad_t, &
732 & nl_u, ad_u, &
733 & nl_v, ad_v, &
734# else
735 & nl_ubar, ad_ubar, &
736 & nl_vbar, ad_vbar, &
737# endif
738 & nl_zeta, ad_zeta)
739!
740 CALL precond (ng, tile, model, 'convert gradient to y-space', &
741 & lbi, ubi, lbj, ubj, lbij, ubij, &
742 & imins, imaxs, jmins, jmaxs, &
743 & nstatevar(ng), lscale, ltrans, &
744 & innloop, outloop, &
745# ifdef MASKING
746 & rmask, umask, vmask, &
747# endif
748# ifdef ADJUST_BOUNDARY
749# ifdef SOLVE3D
750 & nl_t_obc, nl_u_obc, nl_v_obc, &
751# endif
752 & nl_ubar_obc, nl_vbar_obc, &
753 & nl_zeta_obc, &
754# endif
755# ifdef ADJUST_WSTRESS
756 & nl_ustr, nl_vstr, &
757# endif
758# ifdef SOLVE3D
759# ifdef ADJUST_STFLUX
760 & nl_tflux, &
761# endif
762 & nl_t, nl_u, nl_v, &
763# else
764 & nl_ubar, nl_vbar, &
765# endif
766 & nl_zeta)
767 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
768!
769! Copy nl_var(L1) into ad_var(L2).
770!
771 CALL state_copy (ng, tile, &
772 & lbi, ubi, lbj, ubj, lbij, ubij, &
773 & l1, l2, &
774# ifdef ADJUST_BOUNDARY
775# ifdef SOLVE3D
776 & ad_t_obc, nl_t_obc, &
777 & ad_u_obc, nl_u_obc, &
778 & ad_v_obc, nl_v_obc, &
779# endif
780 & ad_ubar_obc, nl_ubar_obc, &
781 & ad_vbar_obc, nl_vbar_obc, &
782 & ad_zeta_obc, nl_zeta_obc, &
783# endif
784# ifdef ADJUST_WSTRESS
785 & ad_ustr, nl_ustr, &
786 & ad_vstr, nl_vstr, &
787# endif
788# ifdef SOLVE3D
789# ifdef ADJUST_STFLUX
790 & ad_tflux, nl_tflux, &
791# endif
792 & ad_t, nl_t, &
793 & ad_u, nl_u, &
794 & ad_v, nl_v, &
795# else
796 & ad_ubar, nl_ubar, &
797 & ad_vbar, nl_vbar, &
798# endif
799 & ad_zeta, nl_zeta)
800!
801 END IF
802!
803! Estimate the Hessian. Note that ad_var(Lold) will be in y-space
804! already if preconditioning since all of the Lanczos vectors saved
805! in the ADM(ng)%name file will be in y-space.
806!
807 IF (innloop.gt.0) THEN
808 lwrk=2
809 linp=1
810 lout=2
811 CALL hessian (ng, tile, model, &
812 & lbi, ubi, lbj, ubj, lbij, ubij, &
813 & imins, imaxs, jmins, jmaxs, &
814 & linp, lout, lwrk, &
815 & innloop, outloop, &
816# ifdef MASKING
817 & rmask, umask, vmask, &
818# endif
819# ifdef ADJUST_BOUNDARY
820# ifdef SOLVE3D
821 & ad_t_obc, ad_u_obc, ad_v_obc, &
822# endif
823 & ad_ubar_obc, ad_vbar_obc, &
824 & ad_zeta_obc, &
825# endif
826# ifdef ADJUST_WSTRESS
827 & ad_ustr, ad_vstr, &
828# endif
829# ifdef SOLVE3D
830# ifdef ADJUST_STFLUX
831 & ad_tflux, &
832# endif
833 & ad_t, ad_u, ad_v, &
834# else
835 & ad_ubar, ad_vbar, &
836# endif
837 & ad_zeta, &
838# ifdef ADJUST_BOUNDARY
839# ifdef SOLVE3D
840 & tl_t_obc, tl_u_obc, tl_v_obc, &
841# endif
842 & tl_ubar_obc, tl_vbar_obc, &
843 & tl_zeta_obc, &
844# endif
845# ifdef ADJUST_WSTRESS
846 & tl_ustr, tl_vstr, &
847# endif
848# ifdef SOLVE3D
849# ifdef ADJUST_STFLUX
850 & tl_tflux, &
851# endif
852 & tl_t, tl_u, tl_v, &
853# else
854 & tl_ubar, tl_vbar, &
855# endif
856 & tl_zeta)
857 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
858!
859! Check for positive Hessian of J.
860!
861 IF (cg_delta(innloop,outloop).le.0.0_r8) THEN
862 WRITE (stdout,*) ' CG_DELTA not positive.'
863 WRITE (stdout,*) ' CG_DELTA = ', cg_delta(innloop,outloop), &
864 & ', outer = ', outloop, ', inner = ', innloop
865 exit_flag=8
866 RETURN
867 END IF
868 END IF
869!
870! Apply the Lanczos recurrence and orthonormalize.
871! If preconditioning, the Lanczos recursion relation is identical
872! in v-space and y-space, and all ad_var are in y-space already.
873!
874 linp=1
875 lout=2
876 lwrk=2
877 CALL lanczos (ng, tile, model, &
878 & lbi, ubi, lbj, ubj, lbij, ubij, &
879 & imins, imaxs, jmins, jmaxs, &
880 & linp, lout, lwrk, &
881 & innloop, outloop, &
882# ifdef MASKING
883 & rmask, umask, vmask, &
884# endif
885# ifdef ADJUST_BOUNDARY
886# ifdef SOLVE3D
887 & tl_t_obc, tl_u_obc, tl_v_obc, &
888# endif
889 & tl_ubar_obc, tl_vbar_obc, &
890 & tl_zeta_obc, &
891# endif
892# ifdef ADJUST_WSTRESS
893 & tl_ustr, tl_vstr, &
894# endif
895# ifdef SOLVE3D
896# ifdef ADJUST_STFLUX
897 & tl_tflux, &
898# endif
899 & tl_t, tl_u, tl_v, &
900# else
901 & tl_ubar, tl_vbar, &
902# endif
903 & tl_zeta, &
904# ifdef ADJUST_BOUNDARY
905# ifdef SOLVE3D
906 & ad_t_obc, ad_u_obc, ad_v_obc, &
907# endif
908 & ad_ubar_obc, ad_vbar_obc, &
909 & ad_zeta_obc, &
910# endif
911# ifdef ADJUST_WSTRESS
912 & ad_ustr, ad_vstr, &
913# endif
914# ifdef SOLVE3D
915# ifdef ADJUST_STFLUX
916 & ad_tflux, &
917# endif
918 & ad_t, ad_u, ad_v, &
919# else
920 & ad_ubar, ad_vbar, &
921# endif
922 & ad_zeta)
923 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
924!
925! Compute new direction, d(k+1).
926!
927 CALL new_direction (ng, tile, model, &
928 & lbi, ubi, lbj, ubj, lbij, ubij, &
929 & imins, imaxs, jmins, jmaxs, &
930 & linp, lout, &
931# ifdef MASKING
932 & rmask, umask, vmask, &
933# endif
934# ifdef ADJUST_BOUNDARY
935# ifdef SOLVE3D
936 & ad_t_obc, ad_u_obc, ad_v_obc, &
937# endif
938 & ad_ubar_obc, ad_vbar_obc, &
939 & ad_zeta_obc, &
940# endif
941# ifdef ADJUST_WSTRESS
942 & ad_ustr, ad_vstr, &
943# endif
944# ifdef SOLVE3D
945# ifdef ADJUST_STFLUX
946 & ad_tflux, &
947# endif
948 & ad_t, ad_u, ad_v, &
949# else
950 & ad_ubar, ad_vbar, &
951# endif
952 & ad_zeta, &
953# ifdef ADJUST_BOUNDARY
954# ifdef SOLVE3D
955 & d_t_obc, d_u_obc, d_v_obc, &
956# endif
957 & d_ubar_obc, d_vbar_obc, &
958 & d_zeta_obc, &
959# endif
960# ifdef ADJUST_WSTRESS
961 & d_sustr, d_svstr, &
962# endif
963# ifdef SOLVE3D
964# ifdef ADJUST_STFLUX
965 & d_stflx, &
966# endif
967 & d_t, d_u, d_v, &
968# else
969 & d_ubar, d_vbar, &
970# endif
971 & d_zeta)
972 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
973!
974!-----------------------------------------------------------------------
975! Calculate the reduction in the gradient norm by solving a
976! tridiagonal system.
977!-----------------------------------------------------------------------
978!
979! Decomposition and forward substitution.
980!
981 IF (innloop.gt.0) THEN
982 zbeta=cg_delta(1,outloop)
983 cg_zu(1,outloop)=-cg_qg(1,outloop)/zbeta
984 END IF
985!
986 IF (innloop.gt.1) THEN
987 DO i=2,innloop
988 cg_gamma(i,outloop)=cg_beta(i,outloop)/zbeta
989 zbeta=cg_delta(i,outloop)- &
990 & cg_beta(i,outloop)*cg_gamma(i,outloop)
991 cg_zu(i,outloop)=(-cg_qg(i,outloop)- &
992 & cg_beta(i,outloop)*cg_zu(i-1,outloop))/zbeta
993 END DO
994!
995! Back substitution.
996!
997 cg_tmatrix(innloop,3)=cg_zu(innloop,outloop)
998 DO i=innloop-1,1,-1
999 cg_zu(i,outloop)=cg_zu(i,outloop)- &
1000 & cg_gamma(i+1,outloop)*cg_zu(i+1,outloop)
1001 cg_tmatrix(i,3)=cg_zu(i,outloop)
1002 END DO
1003!
1004! Compute gradient norm using ad_var(:,:,1) and tl_var(:,:,2) as
1005! temporary storage.
1006!
1007 linp=1
1008 lout=2
1009 lwrk=2
1010 CALL new_gradient (ng, tile, model, &
1011 & lbi, ubi, lbj, ubj, lbij, ubij, &
1012 & imins, imaxs, jmins, jmaxs, &
1013 & linp, lout, lwrk, &
1014 & innloop, outloop, &
1015# ifdef MASKING
1016 & rmask, umask, vmask, &
1017# endif
1018# ifdef ADJUST_BOUNDARY
1019# ifdef SOLVE3D
1020 & tl_t_obc, tl_u_obc, tl_v_obc, &
1021# endif
1022 & tl_ubar_obc, tl_vbar_obc, &
1023 & tl_zeta_obc, &
1024# endif
1025# ifdef ADJUST_WSTRESS
1026 & tl_ustr, tl_vstr, &
1027# endif
1028# ifdef SOLVE3D
1029# ifdef ADJUST_STFLUX
1030 & tl_tflux, &
1031# endif
1032 & tl_t, tl_u, tl_v, &
1033# else
1034 & tl_ubar, tl_vbar, &
1035# endif
1036 & tl_zeta, &
1037# ifdef ADJUST_BOUNDARY
1038# ifdef SOLVE3D
1039 & ad_t_obc, ad_u_obc, ad_v_obc, &
1040# endif
1041 & ad_ubar_obc, ad_vbar_obc, &
1042 & ad_zeta_obc, &
1043# endif
1044# ifdef ADJUST_WSTRESS
1045 & ad_ustr, ad_vstr, &
1046# endif
1047# ifdef SOLVE3D
1048# ifdef ADJUST_STFLUX
1049 & ad_tflux, &
1050# endif
1051 & ad_t, ad_u, ad_v, &
1052# else
1053 & ad_ubar, ad_vbar, &
1054# endif
1055 & ad_zeta)
1056 END IF
1057!
1058! Compute the new cost function.
1059!
1060 IF (innloop.gt.0) THEN
1061 CALL new_cost (ng, tile, model, &
1062 & lbi, ubi, lbj, ubj, lbij, ubij, &
1063 & imins, imaxs, jmins, jmaxs, &
1064 & innloop, outloop, &
1065# ifdef MASKING
1066 & rmask, umask, vmask, &
1067# endif
1068# ifdef ADJUST_BOUNDARY
1069# ifdef SOLVE3D
1070 & nl_t_obc, nl_u_obc, nl_v_obc, &
1071# endif
1072 & nl_ubar_obc, nl_vbar_obc, &
1073 & nl_zeta_obc, &
1074# endif
1075# ifdef ADJUST_WSTRESS
1076 & nl_ustr, nl_vstr, &
1077# endif
1078# ifdef SOLVE3D
1079# ifdef ADJUST_STFLUX
1080 & nl_tflux, &
1081# endif
1082 & nl_t, nl_u, nl_v, &
1083# else
1084 & nl_ubar, nl_vbar, &
1085# endif
1086 & nl_zeta)
1087 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1088 END IF
1089!
1090!-----------------------------------------------------------------------
1091! Determine the eigenvalues and eigenvectors of the tridiagonal matrix.
1092! These will be used on the last inner-loop to compute the eigenvectors
1093! of the Hessian.
1094!-----------------------------------------------------------------------
1095!
1096 IF (innloop.gt.0) THEN
1097 IF (lprecond.or.lhessianev) THEN
1098 DO i=1,innloop
1099 cg_ritz(i,outloop)=cg_delta(i,outloop)
1100 END DO
1101 DO i=1,innloop-1
1102 cg_tmatrix(i,1)=cg_beta(i+1,outloop)
1103 END DO
1104!
1105! Use the LAPACK routine DSTEQR to compute the eigenvectors and
1106! eigenvalues of the tridiagonal matrix. If applicable, the
1107! eigenpairs is computed by master thread only. Notice that on
1108! exit, the matrix cg_Tmatrix is destroyed.
1109!
1110 IF (master) THEN
1111 CALL dsteqr ('I', innloop, cg_ritz(1,outloop), cg_tmatrix, &
1112 & cg_zv, ninner, work, info)
1113 END IF
1114# ifdef DISTRIBUTE
1115 CALL mp_bcasti (ng, model, info)
1116# endif
1117 IF (info.ne.0) THEN
1118 WRITE (stdout,*) ' Error in DSTEQR: info = ', info
1119 exit_flag=8
1120 RETURN
1121 END IF
1122# ifdef DISTRIBUTE
1123 CALL mp_bcastf (ng, model, cg_ritz(:,outloop))
1124 CALL mp_bcastf (ng, model, cg_zv)
1125# endif
1126!
1127! Estimate the Ritz value error bounds.
1128!
1129 DO i=1,innloop
1130 cg_ritzerr(i,outloop)=abs(cg_beta(innloop+1,outloop)* &
1131 & cg_zv(innloop,i))
1132 END DO
1133!
1134! Check for exploding or negative Ritz values.
1135!
1136 DO i=1,innloop
1137 IF (cg_ritz(i,outloop).lt.0.0_r8) THEN
1138 WRITE (stdout,*) ' Negative Ritz value found.'
1139 exit_flag=8
1140 RETURN
1141 END IF
1142 END DO
1143!
1144! Calculate the converged eigenvectors of the Hessian.
1145!
1146 IF (innloop.eq.ninner) THEN
1147 DO i=1,innloop
1148 cg_ritzerr(i,outloop)=cg_ritzerr(i,outloop)/ &
1149 & cg_ritz(ninner,outloop)
1150 END DO
1151 lwrk=2
1152 linp=1
1153 lout=2
1154 CALL hessian_evecs (ng, tile, model, &
1155 & lbi, ubi, lbj, ubj, lbij, ubij, &
1156 & imins, imaxs, jmins, jmaxs, &
1157 & linp, lout, lwrk, &
1158 & innloop, outloop, &
1159# ifdef MASKING
1160 & rmask, umask, vmask, &
1161# endif
1162# ifdef ADJUST_BOUNDARY
1163# ifdef SOLVE3D
1164 & nl_t_obc, nl_u_obc, nl_v_obc, &
1165# endif
1166 & nl_ubar_obc, nl_vbar_obc, &
1167 & nl_zeta_obc, &
1168# endif
1169# ifdef ADJUST_WSTRESS
1170 & nl_ustr, nl_vstr, &
1171# endif
1172# ifdef SOLVE3D
1173# ifdef ADJUST_STFLUX
1174 & nl_tflux, &
1175# endif
1176 & nl_t, nl_u, nl_v, &
1177# else
1178 & nl_ubar, nl_vbar, &
1179# endif
1180 & nl_zeta, &
1181# ifdef ADJUST_BOUNDARY
1182# ifdef SOLVE3D
1183 & tl_t_obc, tl_u_obc, tl_v_obc, &
1184# endif
1185 & tl_ubar_obc, tl_vbar_obc, &
1186
1187 & tl_zeta_obc, &
1188# endif
1189# ifdef ADJUST_WSTRESS
1190 & tl_ustr, tl_vstr, &
1191# endif
1192# ifdef SOLVE3D
1193# ifdef ADJUST_STFLUX
1194 & tl_tflux, &
1195# endif
1196 & tl_t, tl_u, tl_v, &
1197# else
1198 & tl_ubar, tl_vbar, &
1199# endif
1200 & tl_zeta, &
1201# ifdef ADJUST_BOUNDARY
1202# ifdef SOLVE3D
1203 & ad_t_obc, ad_u_obc, ad_v_obc, &
1204# endif
1205 & ad_ubar_obc, ad_vbar_obc, &
1206 & ad_zeta_obc, &
1207# endif
1208# ifdef ADJUST_WSTRESS
1209 & ad_ustr, ad_vstr, &
1210# endif
1211# ifdef SOLVE3D
1212# ifdef ADJUST_STFLUX
1213 & ad_tflux, &
1214# endif
1215 & ad_t, ad_u, ad_v, &
1216# else
1217 & ad_ubar, ad_vbar, &
1218# endif
1219 & ad_zeta)
1220 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1221
1222 IF (master.and.(nconvritz.eq.0)) THEN
1223 WRITE (stdout,*) ' No converged Hesssian eigenvectors', &
1224 & ' found.'
1225 END IF
1226 END IF
1227 END IF
1228 END IF
1229!
1230!-----------------------------------------------------------------------
1231! Set TLM initial conditions for next inner loop, X(k+1).
1232!-----------------------------------------------------------------------
1233!
1234! X(k+1) = tau(k+1) * d(k+1)
1235!
1236! For the Lanczos algorithm, X(Linp) is ALWAYS the starting TLM
1237! initial condition which for incremental 4DVar is zero.
1238!
1239 linp=1
1240 lout=2
1241 CALL tl_new_state (ng, tile, model, &
1242 & lbi, ubi, lbj, ubj, lbij, ubij, &
1243 & imins, imaxs, jmins, jmaxs, &
1244 & linp, lout, &
1245 & innloop, outloop, &
1246# ifdef MASKING
1247 & rmask, umask, vmask, &
1248# endif
1249# ifdef ADJUST_BOUNDARY
1250# ifdef SOLVE3D
1251 & d_t_obc, d_u_obc, d_v_obc, &
1252# endif
1253 & d_ubar_obc, d_vbar_obc, &
1254 & d_zeta_obc, &
1255# endif
1256# ifdef ADJUST_WSTRESS
1257 & d_sustr, d_svstr, &
1258# endif
1259# ifdef SOLVE3D
1260# ifdef ADJUST_STFLUX
1261 & d_stflx, &
1262# endif
1263 & d_t, d_u, d_v, &
1264# else
1265 & d_ubar, d_vbar, &
1266# endif
1267 & d_zeta, &
1268# ifdef ADJUST_BOUNDARY
1269# ifdef SOLVE3D
1270 & tl_t_obc, tl_u_obc, tl_v_obc, &
1271# endif
1272 & tl_ubar_obc, tl_vbar_obc, &
1273 & tl_zeta_obc, &
1274# endif
1275# ifdef ADJUST_WSTRESS
1276 & tl_ustr, tl_vstr, &
1277# endif
1278# ifdef SOLVE3D
1279# ifdef ADJUST_STFLUX
1280 & tl_tflux, &
1281# endif
1282 & tl_t, tl_u, tl_v, &
1283# else
1284 & tl_ubar, tl_vbar, &
1285# endif
1286 & tl_zeta, &
1287# ifdef ADJUST_BOUNDARY
1288# ifdef SOLVE3D
1289 & ad_t_obc, ad_u_obc, ad_v_obc, &
1290# endif
1291 & ad_ubar_obc, ad_vbar_obc, &
1292 & ad_zeta_obc, &
1293# endif
1294# ifdef ADJUST_WSTRESS
1295 & ad_ustr, ad_vstr, &
1296# endif
1297# ifdef SOLVE3D
1298# ifdef ADJUST_STFLUX
1299 & ad_tflux, &
1300# endif
1301 & ad_t, ad_u, ad_v, &
1302# else
1303 & ad_ubar, ad_vbar, &
1304# endif
1305 & ad_zeta)
1306!
1307! If preconditioning, convert tl_var(Lout) back into v-space.
1308!
1309 IF (lprecond.and.(outloop.gt.1)) THEN
1310
1311 lscale=2 ! SQRT spectral LMP
1312 ltrans=.false.
1313!
1314! Copy tl_var(Lout) into nl_var(L1).
1315!
1316 CALL state_copy (ng, tile, &
1317 & lbi, ubi, lbj, ubj, lbij, ubij, &
1318 & lout, l1, &
1319# ifdef ADJUST_BOUNDARY
1320# ifdef SOLVE3D
1321 & nl_t_obc, tl_t_obc, &
1322 & nl_u_obc, tl_u_obc, &
1323 & nl_v_obc, tl_v_obc, &
1324# endif
1325 & nl_ubar_obc, tl_ubar_obc, &
1326 & nl_vbar_obc, tl_vbar_obc, &
1327 & nl_zeta_obc, tl_zeta_obc, &
1328# endif
1329# ifdef ADJUST_WSTRESS
1330 & nl_ustr, tl_ustr, &
1331 & nl_vstr, tl_vstr, &
1332# endif
1333# ifdef SOLVE3D
1334# ifdef ADJUST_STFLUX
1335 & nl_tflux, tl_tflux, &
1336# endif
1337 & nl_t, tl_t, &
1338 & nl_u, tl_u, &
1339 & nl_v, tl_v, &
1340# else
1341 & nl_ubar, tl_ubar, &
1342 & nl_vbar, tl_vbar, &
1343# endif
1344 & nl_zeta, tl_zeta)
1345!
1346 CALL precond (ng, tile, model, 'convert increment to v-space', &
1347 & lbi, ubi, lbj, ubj, lbij, ubij, &
1348 & imins, imaxs, jmins, jmaxs, &
1349 & nstatevar(ng), lscale, ltrans, &
1350 & innloop, outloop, &
1351# ifdef MASKING
1352 & rmask, umask, vmask, &
1353# endif
1354# ifdef ADJUST_BOUNDARY
1355# ifdef SOLVE3D
1356 & nl_t_obc, nl_u_obc, nl_v_obc, &
1357# endif
1358 & nl_ubar_obc, nl_vbar_obc, &
1359 & nl_zeta_obc, &
1360# endif
1361# ifdef ADJUST_WSTRESS
1362 & nl_ustr, nl_vstr, &
1363# endif
1364# ifdef SOLVE3D
1365# ifdef ADJUST_STFLUX
1366 & nl_tflux, &
1367# endif
1368 & nl_t, nl_u, nl_v, &
1369# else
1370 & nl_ubar, nl_vbar, &
1371# endif
1372 & nl_zeta)
1373 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1374!
1375! Copy nl_var(L1) into tl_var(Lout)
1376!
1377 CALL state_copy (ng, tile, &
1378 & lbi, ubi, lbj, ubj, lbij, ubij, &
1379 & l1, lout, &
1380# ifdef ADJUST_BOUNDARY
1381# ifdef SOLVE3D
1382 & tl_t_obc, nl_t_obc, &
1383 & tl_u_obc, nl_u_obc, &
1384 & tl_v_obc, nl_v_obc, &
1385# endif
1386 & tl_ubar_obc, nl_ubar_obc, &
1387 & tl_vbar_obc, nl_vbar_obc, &
1388 & tl_zeta_obc, nl_zeta_obc, &
1389# endif
1390# ifdef ADJUST_WSTRESS
1391 & tl_ustr, nl_ustr, &
1392 & tl_vstr, nl_vstr, &
1393# endif
1394# ifdef SOLVE3D
1395# ifdef ADJUST_STFLUX
1396 & tl_tflux, nl_tflux, &
1397# endif
1398 & tl_t, nl_t, &
1399 & tl_u, nl_u, &
1400 & tl_v, nl_v, &
1401# else
1402 & tl_ubar, nl_ubar, &
1403 & tl_vbar, nl_vbar, &
1404# endif
1405 & tl_zeta, nl_zeta)
1406 END IF
1407!
1408!-----------------------------------------------------------------------
1409! Write out conjugate gradient information into NetCDF file.
1410!-----------------------------------------------------------------------
1411!
1412 CALL cg_write_cgradient (ng, model, innloop, outloop)
1413 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1414!
1415! Report algorithm parameters.
1416!
1417 IF (master) THEN
1418 IF (inner.eq.0) THEN
1419 WRITE (stdout,20) outloop, innloop, &
1420 & cg_gnorm(outloop)
1421 20 FORMAT (/,1x,'(',i3.3,',',i3.3,'): ', &
1422 & 'Initial gradient norm, Gnorm = ',1p,e14.7)
1423 END IF
1424 IF (innloop.gt.0) THEN
1425 WRITE (stdout,30) outloop, innloop, &
1426 & cg_greduc(innloop,outloop), &
1427 & outloop, innloop, &
1428 & cg_delta(innloop,outloop)
1429 30 FORMAT (/,1x,'(',i3.3,',',i3.3,'): ', &
1430 & 'Reduction in the gradient norm, Greduc = ', &
1431 & 1p,e14.7,/, &
1432 & 1x,'(',i3.3,',',i3.3,'): ', &
1433 & 'Lanczos algorithm coefficient, delta = ', &
1434 & 1p,e14.7)
1435 WRITE (stdout,40) ritzmaxerr
1436 40 FORMAT (/,' Ritz Eigenvalues and relative accuracy: ', &
1437 & 'RitzMaxErr = ',1p,e14.7,/)
1438 ic=0
1439 DO i=1,innloop
1440 IF (cg_ritzerr(i,outloop).le.ritzmaxerr) THEN
1441 string='converged'
1442 ic=ic+1
1443 WRITE (stdout,50) i, cg_ritz(i,outloop), &
1444 & cg_ritzerr(i,outloop), &
1445 & trim(adjustl(string)), ic
1446 50 FORMAT(5x,i3.3,2x,1p,e14.7,2x,1p,e14.7,2x,a,2x, &
1447 & '(Good='i3.3,')')
1448 ELSE
1449 string='not converged'
1450 WRITE (stdout,60) i, cg_ritz(i,outloop), &
1451 & cg_ritzerr(i,outloop), &
1452 & trim(adjustl(string))
1453 60 FORMAT(5x,i3.3,2x,1p,e14.7,2x,1p,e14.7,2x,a)
1454 END IF
1455 END DO
1456 END IF
1457 END IF
1458!
1459 RETURN

References mod_fourdvar::cg_beta, mod_fourdvar::cg_delta, mod_fourdvar::cg_gamma, mod_fourdvar::cg_gnorm, mod_fourdvar::cg_greduc, mod_fourdvar::cg_qg, mod_fourdvar::cg_ritz, mod_fourdvar::cg_ritzerr, mod_fourdvar::cg_tmatrix, cg_write_cgradient(), mod_fourdvar::cg_zu, mod_fourdvar::cg_zv, lapack_mod::dsteqr(), mod_scalars::exit_flag, strings_mod::founderror(), hessian(), hessian_evecs(), mod_fourdvar::hevecerr, mod_scalars::inner, lanczos(), mod_fourdvar::lhessianev, mod_fourdvar::lprecond, mod_parallel::master, mod_fourdvar::nconvritz, new_cost(), new_direction(), new_gradient(), mod_scalars::ninner, mod_scalars::noerror, mod_fourdvar::nstatevar, precond(), mod_fourdvar::ritzmaxerr, state_copy_mod::state_copy(), mod_iounits::stdout, and tl_new_state().

Referenced by cgradient().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ hessian()

subroutine, private cgradient_mod::hessian ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) model,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
integer, intent(in) lbij,
integer, intent(in) ubij,
integer, intent(in) imins,
integer, intent(in) imaxs,
integer, intent(in) jmins,
integer, intent(in) jmaxs,
integer, intent(in) lold,
integer, intent(in) lnew,
integer, intent(in) lwrk,
integer, intent(in) innloop,
integer, intent(in) outloop,
real(r8), dimension(lbi:,lbj:), intent(in) rmask,
real(r8), dimension(lbi:,lbj:), intent(in) umask,
real(r8), dimension(lbi:,lbj:), intent(in) vmask,
real(r8), dimension(lbij:,:,:,:,:,:), intent(inout) ad_t_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) ad_u_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) ad_v_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) ad_ubar_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) ad_vbar_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) ad_zeta_obc,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) ad_ustr,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) ad_vstr,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) ad_tflux,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) ad_t,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) ad_u,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) ad_v,
real(r8), dimension(lbi:,lbj:,:), intent(inout) ad_zeta,
real(r8), dimension(lbij:,:,:,:,:,:), intent(inout) tl_t_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) tl_u_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) tl_v_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) tl_ubar_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) tl_vbar_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) tl_zeta_obc,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) tl_ustr,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) tl_vstr,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) tl_tflux,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) tl_t,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) tl_u,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) tl_v,
real(r8), dimension(lbi:,lbj:,:), intent(inout) tl_zeta )
private

Definition at line 3057 of file cgradient.F.

3103!***********************************************************************
3104!
3105! Imported variable declarations.
3106!
3107 integer, intent(in) :: ng, tile, model
3108 integer, intent(in) :: LBi, UBi, LBj, UBj, LBij, UBij
3109 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
3110 integer, intent(in) :: Lold, Lnew, Lwrk
3111 integer, intent(in) :: innLoop, outLoop
3112!
3113# ifdef ASSUMED_SHAPE
3114# ifdef MASKING
3115 real(r8), intent(in) :: rmask(LBi:,LBj:)
3116 real(r8), intent(in) :: umask(LBi:,LBj:)
3117 real(r8), intent(in) :: vmask(LBi:,LBj:)
3118# endif
3119# ifdef ADJUST_BOUNDARY
3120# ifdef SOLVE3D
3121 real(r8), intent(inout) :: ad_t_obc(LBij:,:,:,:,:,:)
3122 real(r8), intent(inout) :: ad_u_obc(LBij:,:,:,:,:)
3123 real(r8), intent(inout) :: ad_v_obc(LBij:,:,:,:,:)
3124# endif
3125 real(r8), intent(inout) :: ad_ubar_obc(LBij:,:,:,:)
3126 real(r8), intent(inout) :: ad_vbar_obc(LBij:,:,:,:)
3127 real(r8), intent(inout) :: ad_zeta_obc(LBij:,:,:,:)
3128# endif
3129# ifdef ADJUST_WSTRESS
3130 real(r8), intent(inout) :: ad_ustr(LBi:,LBj:,:,:)
3131 real(r8), intent(inout) :: ad_vstr(LBi:,LBj:,:,:)
3132# endif
3133# ifdef SOLVE3D
3134# ifdef ADJUST_STFLUX
3135 real(r8), intent(inout) :: ad_tflux(LBi:,LBj:,:,:,:)
3136# endif
3137 real(r8), intent(inout) :: ad_t(LBi:,LBj:,:,:,:)
3138 real(r8), intent(inout) :: ad_u(LBi:,LBj:,:,:)
3139 real(r8), intent(inout) :: ad_v(LBi:,LBj:,:,:)
3140# else
3141 real(r8), intent(inout) :: ad_ubar(LBi:,LBj:,:)
3142 real(r8), intent(inout) :: ad_vbar(LBi:,LBj:,:)
3143# endif
3144 real(r8), intent(inout) :: ad_zeta(LBi:,LBj:,:)
3145# ifdef ADJUST_BOUNDARY
3146# ifdef SOLVE3D
3147 real(r8), intent(inout) :: tl_t_obc(LBij:,:,:,:,:,:)
3148 real(r8), intent(inout) :: tl_u_obc(LBij:,:,:,:,:)
3149 real(r8), intent(inout) :: tl_v_obc(LBij:,:,:,:,:)
3150# endif
3151 real(r8), intent(inout) :: tl_ubar_obc(LBij:,:,:,:)
3152 real(r8), intent(inout) :: tl_vbar_obc(LBij:,:,:,:)
3153 real(r8), intent(inout) :: tl_zeta_obc(LBij:,:,:,:)
3154# endif
3155# ifdef ADJUST_WSTRESS
3156 real(r8), intent(inout) :: tl_ustr(LBi:,LBj:,:,:)
3157 real(r8), intent(inout) :: tl_vstr(LBi:,LBj:,:,:)
3158# endif
3159# ifdef SOLVE3D
3160# ifdef ADJUST_STFLUX
3161 real(r8), intent(inout) :: tl_tflux(LBi:,LBj:,:,:,:)
3162# endif
3163 real(r8), intent(inout) :: tl_t(LBi:,LBj:,:,:,:)
3164 real(r8), intent(inout) :: tl_u(LBi:,LBj:,:,:)
3165 real(r8), intent(inout) :: tl_v(LBi:,LBj:,:,:)
3166# else
3167 real(r8), intent(inout) :: tl_ubar(LBi:,LBj:,:)
3168 real(r8), intent(inout) :: tl_vbar(LBi:,LBj:,:)
3169# endif
3170 real(r8), intent(inout) :: tl_zeta(LBi:,LBj:,:)
3171
3172# else
3173
3174# ifdef MASKING
3175 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
3176 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
3177 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
3178# endif
3179# ifdef ADJUST_BOUNDARY
3180# ifdef SOLVE3D
3181 real(r8), intent(inout) :: ad_t_obc(LBij:UBij,N(ng),4, &
3182 & Nbrec(ng),2,NT(ng))
3183 real(r8), intent(inout) :: ad_u_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
3184 real(r8), intent(inout) :: ad_v_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
3185# endif
3186 real(r8), intent(inout) :: ad_ubar_obc(LBij:UBij,4,Nbrec(ng),2)
3187 real(r8), intent(inout) :: ad_vbar_obc(LBij:UBij,4,Nbrec(ng),2)
3188 real(r8), intent(inout) :: ad_zeta_obc(LBij:UBij,4,Nbrec(ng),2)
3189# endif
3190# ifdef ADJUST_WSTRESS
3191 real(r8), intent(inout) :: ad_ustr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
3192 real(r8), intent(inout) :: ad_vstr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
3193# endif
3194# ifdef SOLVE3D
3195# ifdef ADJUST_STFLUX
3196 real(r8), intent(inout) :: ad_tflux(LBi:UBi,LBj:UBj, &
3197 & Nfrec(ng),2,NT(ng))
3198# endif
3199 real(r8), intent(inout) :: ad_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
3200 real(r8), intent(inout) :: ad_u(LBi:UBi,LBj:UBj,N(ng),2)
3201 real(r8), intent(inout) :: ad_v(LBi:UBi,LBj:UBj,N(ng),2)
3202# else
3203 real(r8), intent(inout) :: ad_ubar(LBi:UBi,LBj:UBj,:)
3204 real(r8), intent(inout) :: ad_vbar(LBi:UBi,LBj:UBj,:)
3205# endif
3206 real(r8), intent(inout) :: ad_zeta(LBi:UBi,LBj:UBj,:)
3207# ifdef ADJUST_BOUNDARY
3208# ifdef SOLVE3D
3209 real(r8), intent(inout) :: tl_t_obc(LBij:UBij,N(ng),4, &
3210 & Nbrec(ng),2,NT(ng))
3211 real(r8), intent(inout) :: tl_u_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
3212 real(r8), intent(inout) :: tl_v_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
3213# endif
3214 real(r8), intent(inout) :: tl_ubar_obc(LBij:UBij,4,Nbrec(ng),2)
3215 real(r8), intent(inout) :: tl_vbar_obc(LBij:UBij,4,Nbrec(ng),2)
3216 real(r8), intent(inout) :: tl_zeta_obc(LBij:UBij,4,Nbrec(ng),2)
3217# endif
3218# ifdef ADJUST_WSTRESS
3219 real(r8), intent(inout) :: tl_ustr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
3220 real(r8), intent(inout) :: tl_vstr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
3221# endif
3222# ifdef SOLVE3D
3223# ifdef ADJUST_STFLUX
3224 real(r8), intent(inout) :: tl_tflux(LBi:UBi,LBj:UBj, &
3225 & Nfrec(ng),2,NT(ng))
3226# endif
3227 real(r8), intent(inout) :: tl_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
3228 real(r8), intent(inout) :: tl_u(LBi:UBi,LBj:UBj,N(ng),2)
3229 real(r8), intent(inout) :: tl_v(LBi:UBi,LBj:UBj,N(ng),2)
3230# else
3231 real(r8), intent(inout) :: tl_ubar(LBi:UBi,LBj:UBj,:)
3232 real(r8), intent(inout) :: tl_vbar(LBi:UBi,LBj:UBj,:)
3233# endif
3234 real(r8), intent(inout) :: tl_zeta(LBi:UBi,LBj:UBj,:)
3235# endif
3236!
3237! Local variable declarations.
3238!
3239 integer :: i, j, k
3240 integer :: ib, ir, it
3241!
3242 real(r8) :: fac
3243
3244 real(r8), dimension(0:NstateVar(ng)) :: dot
3245!
3246 character (len=256) :: ncname
3247
3248 character (len=*), parameter :: MyFile = &
3249 & __FILE__//", hessian"
3250
3251# include "set_bounds.h"
3252!
3253 calledfrom=myfile
3254 sourcefile=myfile
3255!
3256!-----------------------------------------------------------------------
3257! Estimate the action of the Hessian according to:
3258!
3259! grad(v) = Hv + grad(0)
3260!
3261! where grad(v) is the gradient for current value of v, and grad(0)
3262! is the gradient on the first inner-loop when v=0. Therefore,
3263!
3264! Hv = grad(v) - grad(0).
3265!-----------------------------------------------------------------------
3266!
3267! Need to multiply the adjoint state arrays (index Lold) by zgnorm to
3268! convert back to the non-normalized gradient.
3269!
3270! Free-surface.
3271!
3272 DO j=jstrr,jendr
3273 DO i=istrr,iendr
3274 ad_zeta(i,j,lnew)=ad_zeta(i,j,lnew)- &
3275 & ad_zeta(i,j,lold)* &
3276 & cg_gnorm(outloop)
3277# ifdef MASKING
3278 ad_zeta(i,j,lnew)=ad_zeta(i,j,lnew)*rmask(i,j)
3279# endif
3280 END DO
3281 END DO
3282
3283# ifdef ADJUST_BOUNDARY
3284!
3285! Free-surface open boundaries.
3286!
3287 IF (any(lobc(:,isfsur,ng))) THEN
3288 DO ir=1,nbrec(ng)
3289 IF ((lobc(iwest,isfsur,ng)).and. &
3290 & domain(ng)%Western_Edge(tile)) THEN
3291 ib=iwest
3292 DO j=jstr,jend
3293 ad_zeta_obc(j,ib,ir,lnew)=ad_zeta_obc(j,ib,ir,lnew)- &
3294 & ad_zeta_obc(j,ib,ir,lold)* &
3295 & cg_gnorm(outloop)
3296# ifdef MASKING
3297 ad_zeta_obc(j,ib,ir,lnew)=ad_zeta_obc(j,ib,ir,lnew)* &
3298 & rmask(istr-1,j)
3299# endif
3300 END DO
3301 END IF
3302 IF ((lobc(ieast,isfsur,ng)).and. &
3303 & domain(ng)%Eastern_Edge(tile)) THEN
3304 ib=ieast
3305 DO j=jstr,jend
3306 ad_zeta_obc(j,ib,ir,lnew)=ad_zeta_obc(j,ib,ir,lnew)- &
3307 & ad_zeta_obc(j,ib,ir,lold)* &
3308 & cg_gnorm(outloop)
3309# ifdef MASKING
3310 ad_zeta_obc(j,ib,ir,lnew)=ad_zeta_obc(j,ib,ir,lnew)* &
3311 & rmask(iend+1,j)
3312# endif
3313 END DO
3314 END IF
3315 IF ((lobc(isouth,isfsur,ng)).and. &
3316 & domain(ng)%Southern_Edge(tile)) THEN
3317 ib=isouth
3318 DO i=istr,iend
3319 ad_zeta_obc(i,ib,ir,lnew)=ad_zeta_obc(i,ib,ir,lnew)- &
3320 & ad_zeta_obc(i,ib,ir,lold)* &
3321 & cg_gnorm(outloop)
3322# ifdef MASKING
3323 ad_zeta_obc(i,ib,ir,lnew)=ad_zeta_obc(i,ib,ir,lnew)* &
3324 & rmask(i,jstr-1)
3325# endif
3326 END DO
3327 END IF
3328 IF ((lobc(inorth,isfsur,ng)).and. &
3329 & domain(ng)%Northern_Edge(tile)) THEN
3330 ib=inorth
3331 DO i=istr,iend
3332 ad_zeta_obc(i,ib,ir,lnew)=ad_zeta_obc(i,ib,ir,lnew)- &
3333 & ad_zeta_obc(i,ib,ir,lold)* &
3334 & cg_gnorm(outloop)
3335# ifdef MASKING
3336 ad_zeta_obc(i,ib,ir,lnew)=ad_zeta_obc(i,ib,ir,lnew)* &
3337 & rmask(i,jend+1)
3338# endif
3339 END DO
3340 END IF
3341 END DO
3342 END IF
3343# endif
3344
3345# ifndef SOLVE3D
3346!
3347! 2D U-momentum.
3348!
3349 DO j=jstrr,jendr
3350 DO i=istr,iendr
3351 ad_ubar(i,j,lnew)=ad_ubar(i,j,lnew)- &
3352 & ad_ubar(i,j,lold)* &
3353 & cg_gnorm(outloop)
3354# ifdef MASKING
3355 ad_ubar(i,j,lnew)=ad_ubar(i,j,lnew)*umask(i,j)
3356# endif
3357 END DO
3358 END DO
3359# endif
3360
3361# ifdef ADJUST_BOUNDARY
3362!
3363! 2D U-momentum open boundaries.
3364!
3365 IF (any(lobc(:,isubar,ng))) THEN
3366 DO ir=1,nbrec(ng)
3367 IF ((lobc(iwest,isubar,ng)).and. &
3368 & domain(ng)%Western_Edge(tile)) THEN
3369 ib=iwest
3370 DO j=jstr,jend
3371 ad_ubar_obc(j,ib,ir,lnew)=ad_ubar_obc(j,ib,ir,lnew)- &
3372 & ad_ubar_obc(j,ib,ir,lold)* &
3373 & cg_gnorm(outloop)
3374# ifdef MASKING
3375 ad_ubar_obc(j,ib,ir,lnew)=ad_ubar_obc(j,ib,ir,lnew)* &
3376 & umask(istr,j)
3377# endif
3378 END DO
3379 END IF
3380 IF ((lobc(ieast,isubar,ng)).and. &
3381 & domain(ng)%Eastern_Edge(tile)) THEN
3382 ib=ieast
3383 DO j=jstr,jend
3384 ad_ubar_obc(j,ib,ir,lnew)=ad_ubar_obc(j,ib,ir,lnew)- &
3385 & ad_ubar_obc(j,ib,ir,lold)* &
3386 & cg_gnorm(outloop)
3387# ifdef MASKING
3388 ad_ubar_obc(j,ib,ir,lnew)=ad_ubar_obc(j,ib,ir,lnew)* &
3389 & umask(iend+1,j)
3390# endif
3391 END DO
3392 END IF
3393 IF ((lobc(isouth,isubar,ng)).and. &
3394 & domain(ng)%Southern_Edge(tile)) THEN
3395 ib=isouth
3396 DO i=istru,iend
3397 ad_ubar_obc(i,ib,ir,lnew)=ad_ubar_obc(i,ib,ir,lnew)- &
3398 & ad_ubar_obc(i,ib,ir,lold)* &
3399 & cg_gnorm(outloop)
3400# ifdef MASKING
3401 ad_ubar_obc(i,ib,ir,lnew)=ad_ubar_obc(i,ib,ir,lnew)* &
3402 & umask(i,jstr-1)
3403# endif
3404 END DO
3405 END IF
3406 IF ((lobc(inorth,isubar,ng)).and. &
3407 & domain(ng)%Northern_Edge(tile)) THEN
3408 ib=inorth
3409 DO i=istru,iend
3410 ad_ubar_obc(i,ib,ir,lnew)=ad_ubar_obc(i,ib,ir,lnew)- &
3411 & ad_ubar_obc(i,ib,ir,lold)* &
3412 & cg_gnorm(outloop)
3413# ifdef MASKING
3414 ad_ubar_obc(i,ib,ir,lnew)=ad_ubar_obc(i,ib,ir,lnew)* &
3415 & umask(i,jend+1)
3416# endif
3417 END DO
3418 END IF
3419 END DO
3420 END IF
3421# endif
3422
3423# ifndef SOLVE3D
3424!
3425! 2D V-momentum.
3426!
3427 DO j=jstr,jendr
3428 DO i=istrr,iendr
3429 ad_vbar(i,j,lnew)=ad_vbar(i,j,lnew)- &
3430 & ad_vbar(i,j,lold)* &
3431 & cg_gnorm(outloop)
3432# ifdef MASKING
3433 ad_vbar(i,j,lnew)=ad_vbar(i,j,lnew)*vmask(i,j)
3434# endif
3435 END DO
3436 END DO
3437# endif
3438
3439# ifdef ADJUST_BOUNDARY
3440!
3441! 2D V-momentum open boundaries.
3442!
3443 IF (any(lobc(:,isvbar,ng))) THEN
3444 DO ir=1,nbrec(ng)
3445 IF ((lobc(iwest,isvbar,ng)).and. &
3446 & domain(ng)%Western_Edge(tile)) THEN
3447 ib=iwest
3448 DO j=jstrv,jend
3449 ad_vbar_obc(j,ib,ir,lnew)=ad_vbar_obc(j,ib,ir,lnew)- &
3450 & ad_vbar_obc(j,ib,ir,lold)* &
3451 & cg_gnorm(outloop)
3452# ifdef MASKING
3453 ad_vbar_obc(j,ib,ir,lnew)=ad_vbar_obc(j,ib,ir,lnew)* &
3454 & vmask(istr-1,j)
3455# endif
3456 END DO
3457 END IF
3458 IF ((lobc(ieast,isvbar,ng)).and. &
3459 & domain(ng)%Eastern_Edge(tile)) THEN
3460 ib=ieast
3461 DO j=jstrv,jend
3462 ad_vbar_obc(j,ib,ir,lnew)=ad_vbar_obc(j,ib,ir,lnew)- &
3463 & ad_vbar_obc(j,ib,ir,lold)* &
3464 & cg_gnorm(outloop)
3465# ifdef MASKING
3466 ad_vbar_obc(j,ib,ir,lnew)=ad_vbar_obc(j,ib,ir,lnew)* &
3467 & vmask(iend+1,j)
3468# endif
3469 END DO
3470 END IF
3471 IF ((lobc(isouth,isvbar,ng)).and. &
3472 & domain(ng)%Southern_Edge(tile)) THEN
3473 ib=isouth
3474 DO i=istr,iend
3475 ad_vbar_obc(i,ib,ir,lnew)=ad_vbar_obc(i,ib,ir,lnew)- &
3476 & ad_vbar_obc(i,ib,ir,lold)* &
3477 & cg_gnorm(outloop)
3478# ifdef MASKING
3479 ad_vbar_obc(i,ib,ir,lnew)=ad_vbar_obc(i,ib,ir,lnew)* &
3480 & vmask(i,jstr)
3481# endif
3482 END DO
3483 END IF
3484 IF ((lobc(inorth,isvbar,ng)).and. &
3485 & domain(ng)%Northern_Edge(tile)) THEN
3486 ib=inorth
3487 DO i=istr,iend
3488 ad_vbar_obc(i,ib,ir,lnew)=ad_vbar_obc(i,ib,ir,lnew)- &
3489 & ad_vbar_obc(i,ib,ir,lold)* &
3490 & cg_gnorm(outloop)
3491# ifdef MASKING
3492 ad_vbar_obc(i,ib,ir,lnew)=ad_vbar_obc(i,ib,ir,lnew)* &
3493 & vmask(i,jend+1)
3494# endif
3495 END DO
3496 END IF
3497 END DO
3498 END IF
3499# endif
3500
3501# ifdef ADJUST_WSTRESS
3502!
3503! Surface momentum stress.
3504!
3505 DO ir=1,nfrec(ng)
3506 DO j=jstrr,jendr
3507 DO i=istr,iendr
3508 ad_ustr(i,j,ir,lnew)=ad_ustr(i,j,ir,lnew)- &
3509 & ad_ustr(i,j,ir,lold)* &
3510 & cg_gnorm(outloop)
3511# ifdef MASKING
3512 ad_ustr(i,j,ir,lnew)=ad_ustr(i,j,ir,lnew)*umask(i,j)
3513# endif
3514 END DO
3515 END DO
3516 DO j=jstr,jendr
3517 DO i=istrr,iendr
3518 ad_vstr(i,j,ir,lnew)=ad_vstr(i,j,ir,lnew)- &
3519 & ad_vstr(i,j,ir,lold)* &
3520 & cg_gnorm(outloop)
3521# ifdef MASKING
3522 ad_vstr(i,j,ir,lnew)=ad_vstr(i,j,ir,lnew)*vmask(i,j)
3523# endif
3524 END DO
3525 END DO
3526 END DO
3527# endif
3528
3529# ifdef SOLVE3D
3530!
3531! 3D U-momentum.
3532!
3533 DO k=1,n(ng)
3534 DO j=jstrr,jendr
3535 DO i=istr,iendr
3536 ad_u(i,j,k,lnew)=ad_u(i,j,k,lnew)- &
3537 & ad_u(i,j,k,lold)* &
3538 & cg_gnorm(outloop)
3539# ifdef MASKING
3540 ad_u(i,j,k,lnew)=ad_u(i,j,k,lnew)*umask(i,j)
3541# endif
3542 END DO
3543 END DO
3544 END DO
3545
3546# ifdef ADJUST_BOUNDARY
3547!
3548! 3D U-momentum open boundaries.
3549!
3550 IF (any(lobc(:,isuvel,ng))) THEN
3551 DO ir=1,nbrec(ng)
3552 IF ((lobc(iwest,isuvel,ng)).and. &
3553 & domain(ng)%Western_Edge(tile)) THEN
3554 ib=iwest
3555 DO k=1,n(ng)
3556 DO j=jstr,jend
3557 ad_u_obc(j,k,ib,ir,lnew)=ad_u_obc(j,k,ib,ir,lnew)- &
3558 & ad_u_obc(j,k,ib,ir,lold)* &
3559 & cg_gnorm(outloop)
3560# ifdef MASKING
3561 ad_u_obc(j,k,ib,ir,lnew)=ad_u_obc(j,k,ib,ir,lnew)* &
3562 & umask(istr,j)
3563# endif
3564 END DO
3565 END DO
3566 END IF
3567 IF ((lobc(ieast,isuvel,ng)).and. &
3568 & domain(ng)%Eastern_Edge(tile)) THEN
3569 ib=ieast
3570 DO k=1,n(ng)
3571 DO j=jstr,jend
3572 ad_u_obc(j,k,ib,ir,lnew)=ad_u_obc(j,k,ib,ir,lnew)- &
3573 & ad_u_obc(j,k,ib,ir,lold)* &
3574 & cg_gnorm(outloop)
3575# ifdef MASKING
3576 ad_u_obc(j,k,ib,ir,lnew)=ad_u_obc(j,k,ib,ir,lnew)* &
3577 & umask(iend+1,j)
3578# endif
3579 END DO
3580 END DO
3581 END IF
3582 IF ((lobc(isouth,isuvel,ng)).and. &
3583 & domain(ng)%Southern_Edge(tile)) THEN
3584 ib=isouth
3585 DO k=1,n(ng)
3586 DO i=istru,iend
3587 ad_u_obc(i,k,ib,ir,lnew)=ad_u_obc(i,k,ib,ir,lnew)- &
3588 & ad_u_obc(i,k,ib,ir,lold)* &
3589 & cg_gnorm(outloop)
3590# ifdef MASKING
3591 ad_u_obc(i,k,ib,ir,lnew)=ad_u_obc(i,k,ib,ir,lnew)* &
3592 & umask(i,jstr-1)
3593# endif
3594 END DO
3595 END DO
3596 END IF
3597 IF ((lobc(inorth,isuvel,ng)).and. &
3598 & domain(ng)%Northern_Edge(tile)) THEN
3599 ib=inorth
3600 DO k=1,n(ng)
3601 DO i=istru,iend
3602 ad_u_obc(i,k,ib,ir,lnew)=ad_u_obc(i,k,ib,ir,lnew)- &
3603 & ad_u_obc(i,k,ib,ir,lold)* &
3604 & cg_gnorm(outloop)
3605# ifdef MASKING
3606 ad_u_obc(i,k,ib,ir,lnew)=ad_u_obc(i,k,ib,ir,lnew)* &
3607 & umask(i,jend+1)
3608# endif
3609 END DO
3610 END DO
3611 END IF
3612 END DO
3613 END IF
3614# endif
3615!
3616! 3D V-momentum.
3617!
3618 DO k=1,n(ng)
3619 DO j=jstr,jendr
3620 DO i=istrr,iendr
3621 ad_v(i,j,k,lnew)=ad_v(i,j,k,lnew)- &
3622 & ad_v(i,j,k,lold)* &
3623 & cg_gnorm(outloop)
3624# ifdef MASKING
3625 ad_v(i,j,k,lnew)=ad_v(i,j,k,lnew)*vmask(i,j)
3626# endif
3627 END DO
3628 END DO
3629 END DO
3630
3631# ifdef ADJUST_BOUNDARY
3632!
3633! 3D V-momentum open boundaries.
3634!
3635 IF (any(lobc(:,isvvel,ng))) THEN
3636 DO ir=1,nbrec(ng)
3637 IF ((lobc(iwest,isvvel,ng)).and. &
3638 & domain(ng)%Western_Edge(tile)) THEN
3639 ib=iwest
3640 DO k=1,n(ng)
3641 DO j=jstrv,jend
3642 ad_v_obc(j,k,ib,ir,lnew)=ad_v_obc(j,k,ib,ir,lnew)- &
3643 & ad_v_obc(j,k,ib,ir,lold)* &
3644 & cg_gnorm(outloop)
3645# ifdef MASKING
3646 ad_v_obc(j,k,ib,ir,lnew)=ad_v_obc(j,k,ib,ir,lnew)* &
3647 & vmask(istr-1,j)
3648# endif
3649 END DO
3650 END DO
3651 END IF
3652 IF ((lobc(ieast,isvvel,ng)).and. &
3653 & domain(ng)%Eastern_Edge(tile)) THEN
3654 ib=ieast
3655 DO k=1,n(ng)
3656 DO j=jstrv,jend
3657 ad_v_obc(j,k,ib,ir,lnew)=ad_v_obc(j,k,ib,ir,lnew)- &
3658 & ad_v_obc(j,k,ib,ir,lold)* &
3659 & cg_gnorm(outloop)
3660# ifdef MASKING
3661 ad_v_obc(j,k,ib,ir,lnew)=ad_v_obc(j,k,ib,ir,lnew)* &
3662 & vmask(iend+1,j)
3663# endif
3664 END DO
3665 END DO
3666 END IF
3667 IF ((lobc(isouth,isvvel,ng)).and. &
3668 & domain(ng)%Southern_Edge(tile)) THEN
3669 ib=isouth
3670 DO k=1,n(ng)
3671 DO i=istr,iend
3672 ad_v_obc(i,k,ib,ir,lnew)=ad_v_obc(i,k,ib,ir,lnew)- &
3673 & ad_v_obc(i,k,ib,ir,lold)* &
3674 & cg_gnorm(outloop)
3675# ifdef MASKING
3676 ad_v_obc(i,k,ib,ir,lnew)=ad_v_obc(i,k,ib,ir,lnew)* &
3677 & vmask(i,jstr)
3678# endif
3679 END DO
3680 END DO
3681 END IF
3682 IF ((lobc(inorth,isvvel,ng)).and. &
3683 & domain(ng)%Northern_Edge(tile)) THEN
3684 ib=inorth
3685 DO k=1,n(ng)
3686 DO i=istr,iend
3687 ad_v_obc(i,k,ib,ir,lnew)=ad_v_obc(i,k,ib,ir,lnew)- &
3688 & ad_v_obc(i,k,ib,ir,lold)* &
3689 & cg_gnorm(outloop)
3690# ifdef MASKING
3691 ad_v_obc(i,k,ib,ir,lnew)=ad_v_obc(i,k,ib,ir,lnew)* &
3692 & vmask(i,jend+1)
3693# endif
3694 END DO
3695 END DO
3696 END IF
3697 END DO
3698 END IF
3699# endif
3700!
3701! Tracers.
3702!
3703 DO it=1,nt(ng)
3704 DO k=1,n(ng)
3705 DO j=jstrr,jendr
3706 DO i=istrr,iendr
3707 ad_t(i,j,k,lnew,it)=ad_t(i,j,k,lnew,it)- &
3708 & ad_t(i,j,k,lold,it)* &
3709 & cg_gnorm(outloop)
3710# ifdef MASKING
3711 ad_t(i,j,k,lnew,it)=ad_t(i,j,k,lnew,it)*rmask(i,j)
3712# endif
3713 END DO
3714 END DO
3715 END DO
3716 END DO
3717
3718# ifdef ADJUST_BOUNDARY
3719!
3720! Tracers open boundaries.
3721!
3722 DO it=1,nt(ng)
3723 IF (any(lobc(:,istvar(it),ng))) THEN
3724 DO ir=1,nbrec(ng)
3725 IF ((lobc(iwest,istvar(it),ng)).and. &
3726 & domain(ng)%Western_Edge(tile)) THEN
3727 ib=iwest
3728 DO k=1,n(ng)
3729 DO j=jstr,jend
3730 ad_t_obc(j,k,ib,ir,lnew,it)= &
3731 & ad_t_obc(j,k,ib,ir,lnew,it)- &
3732 & ad_t_obc(j,k,ib,ir,lold,it)* &
3733 & cg_gnorm(outloop)
3734# ifdef MASKING
3735 ad_t_obc(j,k,ib,ir,lnew,it)= &
3736 & ad_t_obc(j,k,ib,ir,lnew,it)*rmask(istr-1,j)
3737# endif
3738 END DO
3739 END DO
3740 END IF
3741 IF ((lobc(ieast,istvar(it),ng)).and. &
3742 & domain(ng)%Eastern_Edge(tile)) THEN
3743 ib=ieast
3744 DO k=1,n(ng)
3745 DO j=jstr,jend
3746 ad_t_obc(j,k,ib,ir,lnew,it)= &
3747 & ad_t_obc(j,k,ib,ir,lnew,it)- &
3748 & ad_t_obc(j,k,ib,ir,lold,it)* &
3749 & cg_gnorm(outloop)
3750# ifdef MASKING
3751 ad_t_obc(j,k,ib,ir,lnew,it)= &
3752 & ad_t_obc(j,k,ib,ir,lnew,it)*rmask(iend+1,j)
3753# endif
3754 END DO
3755 END DO
3756 END IF
3757 IF ((lobc(isouth,istvar(it),ng)).and. &
3758 & domain(ng)%Southern_Edge(tile)) THEN
3759 ib=isouth
3760 DO k=1,n(ng)
3761 DO i=istr,iend
3762 ad_t_obc(i,k,ib,ir,lnew,it)= &
3763 & ad_t_obc(i,k,ib,ir,lnew,it)- &
3764 & ad_t_obc(i,k,ib,ir,lold,it)* &
3765 & cg_gnorm(outloop)
3766# ifdef MASKING
3767 ad_t_obc(i,k,ib,ir,lnew,it)= &
3768 & ad_t_obc(i,k,ib,ir,lnew,it)*rmask(i,jstr-1)
3769# endif
3770 END DO
3771 END DO
3772 END IF
3773 IF ((lobc(inorth,istvar(it),ng)).and. &
3774 & domain(ng)%Northern_Edge(tile)) THEN
3775 ib=inorth
3776 DO k=1,n(ng)
3777 DO i=istr,iend
3778 ad_t_obc(i,k,ib,ir,lnew,it)= &
3779 & ad_t_obc(i,k,ib,ir,lnew,it)- &
3780 & ad_t_obc(i,k,ib,ir,lold,it)* &
3781 & cg_gnorm(outloop)
3782# ifdef MASKING
3783 ad_t_obc(i,k,ib,ir,lnew,it)= &
3784 & ad_t_obc(i,k,ib,ir,lnew,it)*rmask(i,jend+1)
3785# endif
3786 END DO
3787 END DO
3788 END IF
3789 END DO
3790 END IF
3791 END DO
3792# endif
3793
3794# ifdef ADJUST_STFLUX
3795!
3796! Surface tracers flux.
3797!
3798 DO it=1,nt(ng)
3799 IF (lstflux(it,ng)) THEN
3800 DO ir=1,nfrec(ng)
3801 DO j=jstrr,jendr
3802 DO i=istrr,iendr
3803 ad_tflux(i,j,ir,lnew,it)=ad_tflux(i,j,ir,lnew,it)- &
3804 & ad_tflux(i,j,ir,lold,it)* &
3805 & cg_gnorm(outloop)
3806# ifdef MASKING
3807 ad_tflux(i,j,ir,lnew,it)=ad_tflux(i,j,ir,lnew,it)* &
3808 & rmask(i,j)
3809# endif
3810 END DO
3811 END DO
3812 END DO
3813 END IF
3814 END DO
3815# endif
3816# endif
3817!
3818!-----------------------------------------------------------------------
3819! Compute norm Delta(k) as the dot product between the new gradient
3820! and current iteration gradient solution.
3821!-----------------------------------------------------------------------
3822!
3823! Determine gradient file to process.
3824!
3825 IF (ndefadj(ng).gt.0) THEN
3826 WRITE (ncname,10) trim(adm(ng)%base), outloop
3827 10 FORMAT (a,'_',i3.3,'.nc')
3828 ELSE
3829 ncname=adm(ng)%name
3830 END IF
3831!
3832! Read Lanczos vector on which the Hessian matrix is operating
3833! into tangent linear state array, index Lwrk.
3834!
3835 CALL state_read (ng, tile, model, adm(ng)%IOtype, &
3836 & lbi, ubi, lbj, ubj, lbij, ubij, &
3837 & lwrk, innloop, &
3838 & ndefadj(ng), adm(ng)%ncid, &
3839# if defined PIO_LIB && defined DISTRIBUTE
3840 & adm(ng)%pioFile, &
3841# endif
3842 & ncname, &
3843# ifdef MASKING
3844 & rmask, umask, vmask, &
3845# endif
3846# ifdef ADJUST_BOUNDARY
3847# ifdef SOLVE3D
3848 & tl_t_obc, tl_u_obc, tl_v_obc, &
3849# endif
3850 & tl_ubar_obc, tl_vbar_obc, &
3851 & tl_zeta_obc, &
3852# endif
3853# ifdef ADJUST_WSTRESS
3854 & tl_ustr, tl_vstr, &
3855# endif
3856# ifdef SOLVE3D
3857# ifdef ADJUST_STFLUX
3858 & tl_tflux, &
3859# endif
3860 & tl_t, tl_u, tl_v, &
3861# else
3862 & tl_ubar, tl_vbar, &
3863# endif
3864 & tl_zeta)
3865 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
3866!
3867! Compute current iteration norm Delta(k) used to compute tri-diagonal
3868! matrix T(k) in the Lanczos recurrence.
3869!
3870 CALL state_dotprod (ng, tile, model, &
3871 & lbi, ubi, lbj, ubj, lbij, ubij, &
3872 & nstatevar(ng), dot(0:), &
3873# ifdef MASKING
3874 & rmask, umask, vmask, &
3875# endif
3876# ifdef ADJUST_BOUNDARY
3877# ifdef SOLVE3D
3878 & ad_t_obc(:,:,:,:,lnew,:), &
3879 & tl_t_obc(:,:,:,:,lwrk,:), &
3880 & ad_u_obc(:,:,:,:,lnew), &
3881 & tl_u_obc(:,:,:,:,lwrk), &
3882 & ad_v_obc(:,:,:,:,lnew), &
3883 & tl_v_obc(:,:,:,:,lwrk), &
3884# endif
3885 & ad_ubar_obc(:,:,:,lnew), &
3886 & tl_ubar_obc(:,:,:,lwrk), &
3887 & ad_vbar_obc(:,:,:,lnew), &
3888 & tl_vbar_obc(:,:,:,lwrk), &
3889 & ad_zeta_obc(:,:,:,lnew), &
3890 & tl_zeta_obc(:,:,:,lwrk), &
3891# endif
3892# ifdef ADJUST_WSTRESS
3893 & ad_ustr(:,:,:,lnew), tl_ustr(:,:,:,lwrk), &
3894 & ad_vstr(:,:,:,lnew), tl_vstr(:,:,:,lwrk), &
3895# endif
3896# ifdef SOLVE3D
3897# ifdef ADJUST_STFLUX
3898 & ad_tflux(:,:,:,lnew,:), &
3899 & tl_tflux(:,:,:,lwrk,:), &
3900# endif
3901 & ad_t(:,:,:,lnew,:), tl_t(:,:,:,lwrk,:), &
3902 & ad_u(:,:,:,lnew), tl_u(:,:,:,lwrk), &
3903 & ad_v(:,:,:,lnew), tl_v(:,:,:,lwrk), &
3904# else
3905 & ad_ubar(:,:,lnew), tl_ubar(:,:,lwrk), &
3906 & ad_vbar(:,:,lnew), tl_vbar(:,:,lwrk), &
3907# endif
3908 & ad_zeta(:,:,lnew), tl_zeta(:,:,lwrk))
3909
3910 cg_delta(innloop,outloop)=dot(0)
3911!
3912 RETURN

References mod_iounits::adm, mod_iounits::calledfrom, mod_fourdvar::cg_delta, mod_fourdvar::cg_gnorm, mod_param::domain, mod_scalars::exit_flag, strings_mod::founderror(), mod_scalars::ieast, mod_scalars::inorth, mod_ncparam::isfsur, mod_scalars::isouth, mod_ncparam::istvar, mod_ncparam::isubar, mod_ncparam::isuvel, mod_ncparam::isvbar, mod_ncparam::isvvel, mod_scalars::iwest, mod_stepping::lnew, mod_scalars::lobc, mod_stepping::lold, mod_scalars::lstflux, mod_param::n, mod_scalars::nbrec, mod_scalars::ndefadj, mod_scalars::nfrec, mod_scalars::noerror, mod_fourdvar::nstatevar, mod_param::nt, mod_iounits::sourcefile, state_dotprod_mod::state_dotprod(), and state_read_mod::state_read().

Referenced by cgradient_tile().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ hessian_evecs()

subroutine, private cgradient_mod::hessian_evecs ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) model,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
integer, intent(in) lbij,
integer, intent(in) ubij,
integer, intent(in) imins,
integer, intent(in) imaxs,
integer, intent(in) jmins,
integer, intent(in) jmaxs,
integer, intent(in) lold,
integer, intent(in) lnew,
integer, intent(in) lwrk,
integer, intent(in) innloop,
integer, intent(in) outloop,
real(r8), dimension(lbi:,lbj:), intent(in) rmask,
real(r8), dimension(lbi:,lbj:), intent(in) umask,
real(r8), dimension(lbi:,lbj:), intent(in) vmask,
real(r8), dimension(lbij:,:,:,:,:,:), intent(inout) nl_t_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) nl_u_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) nl_v_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) nl_ubar_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) nl_vbar_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) nl_zeta_obc,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) nl_ustr,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) nl_vstr,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) nl_tflux,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) nl_t,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) nl_u,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) nl_v,
real(r8), dimension(lbi:,lbj:,:), intent(inout) nl_zeta,
real(r8), dimension(lbij:,:,:,:,:,:), intent(inout) tl_t_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) tl_u_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) tl_v_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) tl_ubar_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) tl_vbar_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) tl_zeta_obc,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) tl_ustr,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) tl_vstr,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) tl_tflux,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) tl_t,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) tl_u,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) tl_v,
real(r8), dimension(lbi:,lbj:,:), intent(inout) tl_zeta,
real(r8), dimension(lbij:,:,:,:,:,:), intent(inout) ad_t_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) ad_u_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) ad_v_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) ad_ubar_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) ad_vbar_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) ad_zeta_obc,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) ad_ustr,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) ad_vstr,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) ad_tflux,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) ad_t,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) ad_u,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) ad_v,
real(r8), dimension(lbi:,lbj:,:), intent(inout) ad_zeta )
private

Definition at line 5084 of file cgradient.F.

5149!***********************************************************************
5150!
5151! Imported variable declarations.
5152!
5153 integer, intent(in) :: ng, tile, model
5154 integer, intent(in) :: LBi, UBi, LBj, UBj, LBij, UBij
5155 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
5156 integer, intent(in) :: Lold, Lnew, Lwrk
5157 integer, intent(in) :: innLoop, outLoop
5158!
5159# ifdef ASSUMED_SHAPE
5160# ifdef MASKING
5161 real(r8), intent(in) :: rmask(LBi:,LBj:)
5162 real(r8), intent(in) :: umask(LBi:,LBj:)
5163 real(r8), intent(in) :: vmask(LBi:,LBj:)
5164# endif
5165# ifdef ADJUST_BOUNDARY
5166# ifdef SOLVE3D
5167 real(r8), intent(inout) :: ad_t_obc(LBij:,:,:,:,:,:)
5168 real(r8), intent(inout) :: ad_u_obc(LBij:,:,:,:,:)
5169 real(r8), intent(inout) :: ad_v_obc(LBij:,:,:,:,:)
5170# endif
5171 real(r8), intent(inout) :: ad_ubar_obc(LBij:,:,:,:)
5172 real(r8), intent(inout) :: ad_vbar_obc(LBij:,:,:,:)
5173 real(r8), intent(inout) :: ad_zeta_obc(LBij:,:,:,:)
5174# endif
5175# ifdef ADJUST_WSTRESS
5176 real(r8), intent(inout) :: ad_ustr(LBi:,LBj:,:,:)
5177 real(r8), intent(inout) :: ad_vstr(LBi:,LBj:,:,:)
5178# endif
5179# ifdef SOLVE3D
5180# ifdef ADJUST_STFLUX
5181 real(r8), intent(inout) :: ad_tflux(LBi:,LBj:,:,:,:)
5182# endif
5183 real(r8), intent(inout) :: ad_t(LBi:,LBj:,:,:,:)
5184 real(r8), intent(inout) :: ad_u(LBi:,LBj:,:,:)
5185 real(r8), intent(inout) :: ad_v(LBi:,LBj:,:,:)
5186# else
5187 real(r8), intent(inout) :: ad_ubar(LBi:,LBj:,:)
5188 real(r8), intent(inout) :: ad_vbar(LBi:,LBj:,:)
5189# endif
5190 real(r8), intent(inout) :: ad_zeta(LBi:,LBj:,:)
5191# ifdef ADJUST_BOUNDARY
5192# ifdef SOLVE3D
5193 real(r8), intent(inout) :: tl_t_obc(LBij:,:,:,:,:,:)
5194 real(r8), intent(inout) :: tl_u_obc(LBij:,:,:,:,:)
5195 real(r8), intent(inout) :: tl_v_obc(LBij:,:,:,:,:)
5196# endif
5197 real(r8), intent(inout) :: tl_ubar_obc(LBij:,:,:,:)
5198 real(r8), intent(inout) :: tl_vbar_obc(LBij:,:,:,:)
5199 real(r8), intent(inout) :: tl_zeta_obc(LBij:,:,:,:)
5200# endif
5201# ifdef ADJUST_WSTRESS
5202 real(r8), intent(inout) :: tl_ustr(LBi:,LBj:,:,:)
5203 real(r8), intent(inout) :: tl_vstr(LBi:,LBj:,:,:)
5204# endif
5205# ifdef SOLVE3D
5206# ifdef ADJUST_STFLUX
5207 real(r8), intent(inout) :: tl_tflux(LBi:,LBj:,:,:,:)
5208# endif
5209 real(r8), intent(inout) :: tl_t(LBi:,LBj:,:,:,:)
5210 real(r8), intent(inout) :: tl_u(LBi:,LBj:,:,:)
5211 real(r8), intent(inout) :: tl_v(LBi:,LBj:,:,:)
5212# else
5213 real(r8), intent(inout) :: tl_ubar(LBi:,LBj:,:)
5214 real(r8), intent(inout) :: tl_vbar(LBi:,LBj:,:)
5215# endif
5216 real(r8), intent(inout) :: tl_zeta(LBi:,LBj:,:)
5217# ifdef ADJUST_BOUNDARY
5218# ifdef SOLVE3D
5219 real(r8), intent(inout) :: nl_t_obc(LBij:,:,:,:,:,:)
5220 real(r8), intent(inout) :: nl_u_obc(LBij:,:,:,:,:)
5221 real(r8), intent(inout) :: nl_v_obc(LBij:,:,:,:,:)
5222# endif
5223 real(r8), intent(inout) :: nl_ubar_obc(LBij:,:,:,:)
5224 real(r8), intent(inout) :: nl_vbar_obc(LBij:,:,:,:)
5225 real(r8), intent(inout) :: nl_zeta_obc(LBij:,:,:,:)
5226# endif
5227# ifdef ADJUST_WSTRESS
5228 real(r8), intent(inout) :: nl_ustr(LBi:,LBj:,:,:)
5229 real(r8), intent(inout) :: nl_vstr(LBi:,LBj:,:,:)
5230# endif
5231# ifdef SOLVE3D
5232# ifdef ADJUST_STFLUX
5233 real(r8), intent(inout) :: nl_tflux(LBi:,LBj:,:,:,:)
5234# endif
5235 real(r8), intent(inout) :: nl_t(LBi:,LBj:,:,:,:)
5236 real(r8), intent(inout) :: nl_u(LBi:,LBj:,:,:)
5237 real(r8), intent(inout) :: nl_v(LBi:,LBj:,:,:)
5238# else
5239 real(r8), intent(inout) :: nl_ubar(LBi:,LBj:,:)
5240 real(r8), intent(inout) :: nl_vbar(LBi:,LBj:,:)
5241# endif
5242 real(r8), intent(inout) :: nl_zeta(LBi:,LBj:,:)
5243
5244# else
5245
5246# ifdef MASKING
5247 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
5248 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
5249 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
5250# endif
5251# ifdef ADJUST_BOUNDARY
5252# ifdef SOLVE3D
5253 real(r8), intent(inout) :: ad_t_obc(LBij:UBij,N(ng),4, &
5254 & Nbrec(ng),2,NT(ng))
5255 real(r8), intent(inout) :: ad_u_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
5256 real(r8), intent(inout) :: ad_v_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
5257# endif
5258 real(r8), intent(inout) :: ad_ubar_obc(LBij:UBij,4,Nbrec(ng),2)
5259 real(r8), intent(inout) :: ad_vbar_obc(LBij:UBij,4,Nbrec(ng),2)
5260 real(r8), intent(inout) :: ad_zeta_obc(LBij:UBij,4,Nbrec(ng),2)
5261# endif
5262# ifdef ADJUST_WSTRESS
5263 real(r8), intent(inout) :: ad_ustr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
5264 real(r8), intent(inout) :: ad_vstr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
5265# endif
5266# ifdef SOLVE3D
5267# ifdef ADJUST_STFLUX
5268 real(r8), intent(inout) :: ad_tflux(LBi:UBi,LBj:UBj, &
5269 & Nfrec(ng),2,NT(ng))
5270# endif
5271 real(r8), intent(inout) :: ad_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
5272 real(r8), intent(inout) :: ad_u(LBi:UBi,LBj:UBj,N(ng),2)
5273 real(r8), intent(inout) :: ad_v(LBi:UBi,LBj:UBj,N(ng),2)
5274# else
5275 real(r8), intent(inout) :: ad_ubar(LBi:UBi,LBj:UBj,:)
5276 real(r8), intent(inout) :: ad_vbar(LBi:UBi,LBj:UBj,:)
5277# endif
5278 real(r8), intent(inout) :: ad_zeta(LBi:UBi,LBj:UBj,:)
5279# ifdef ADJUST_BOUNDARY
5280# ifdef SOLVE3D
5281 real(r8), intent(inout) :: tl_t_obc(LBij:UBij,N(ng),4, &
5282 & Nbrec(ng),2,NT(ng))
5283 real(r8), intent(inout) :: tl_u_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
5284 real(r8), intent(inout) :: tl_v_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
5285# endif
5286 real(r8), intent(inout) :: tl_ubar_obc(LBij:UBij,4,Nbrec(ng),2)
5287 real(r8), intent(inout) :: tl_vbar_obc(LBij:UBij,4,Nbrec(ng),2)
5288 real(r8), intent(inout) :: tl_zeta_obc(LBij:UBij,4,Nbrec(ng),2)
5289# endif
5290# ifdef ADJUST_WSTRESS
5291 real(r8), intent(inout) :: tl_ustr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
5292 real(r8), intent(inout) :: tl_vstr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
5293# endif
5294# ifdef SOLVE3D
5295# ifdef ADJUST_STFLUX
5296 real(r8), intent(inout) :: tl_tflux(LBi:UBi,LBj:UBj, &
5297 & Nfrec(ng),2,NT(ng))
5298# endif
5299 real(r8), intent(inout) :: tl_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
5300 real(r8), intent(inout) :: tl_u(LBi:UBi,LBj:UBj,N(ng),2)
5301 real(r8), intent(inout) :: tl_v(LBi:UBi,LBj:UBj,N(ng),2)
5302# else
5303 real(r8), intent(inout) :: tl_ubar(LBi:UBi,LBj:UBj,:)
5304 real(r8), intent(inout) :: tl_vbar(LBi:UBi,LBj:UBj,:)
5305# endif
5306 real(r8), intent(inout) :: tl_zeta(LBi:UBi,LBj:UBj,:)
5307# ifdef ADJUST_BOUNDARY
5308# ifdef SOLVE3D
5309 real(r8), intent(inout) :: nl_t_obc(LBij:UBij,N(ng),4, &
5310 & Nbrec(ng),2,NT(ng))
5311 real(r8), intent(inout) :: nl_u_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
5312 real(r8), intent(inout) :: nl_v_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
5313# endif
5314 real(r8), intent(inout) :: nl_ubar_obc(LBij:UBij,4,Nbrec(ng),2)
5315 real(r8), intent(inout) :: nl_vbar_obc(LBij:UBij,4,Nbrec(ng),2)
5316 real(r8), intent(inout) :: nl_zeta_obc(LBij:UBij,4,Nbrec(ng),2)
5317# endif
5318# ifdef ADJUST_WSTRESS
5319 real(r8), intent(inout) :: nl_ustr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
5320 real(r8), intent(inout) :: nl_vstr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
5321# endif
5322# ifdef SOLVE3D
5323# ifdef ADJUST_STFLUX
5324 real(r8), intent(inout) :: nl_tflux(LBi:UBi,LBj:UBj, &
5325 & Nfrec(ng),2,NT(ng))
5326# endif
5327 real(r8), intent(inout) :: nl_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
5328 real(r8), intent(inout) :: nl_u(LBi:UBi,LBj:UBj,N(ng),2)
5329 real(r8), intent(inout) :: nl_v(LBi:UBi,LBj:UBj,N(ng),2)
5330# else
5331 real(r8), intent(inout) :: nl_ubar(LBi:UBi,LBj:UBj,:)
5332 real(r8), intent(inout) :: nl_vbar(LBi:UBi,LBj:UBj,:)
5333# endif
5334 real(r8), intent(inout) :: nl_zeta(LBi:UBi,LBj:UBj,:)
5335# endif
5336!
5337! Local variable declarations.
5338!
5339 integer :: i, ingood, nvec, rec, status, varid
5340 integer :: L1
5341 integer :: start(4), total(4)
5342!
5343 real(r8) :: fac, fac1, fac2
5344
5345 real(r8), dimension(Ninner) :: RitzErr
5346
5347 real(r8), dimension(0:NstateVar(ng)) :: dot
5348 real(r8), dimension(0:Ninner) :: DotProd, dot_new, dot_old
5349!
5350 character (len=256) :: ncname
5351
5352 character (len=*), parameter :: MyFile = &
5353 & __FILE__//", hessian_evecs"
5354
5355# include "set_bounds.h"
5356!
5357 calledfrom=myfile
5358 sourcefile=myfile
5359!
5360!-----------------------------------------------------------------------
5361! Calculate converged eigenvectors of the Hessian.
5362!-----------------------------------------------------------------------
5363!
5364! Count and collect the converged eigenvalues.
5365!
5366 ingood=0
5367 DO i=innloop,1,-1
5368 ingood=ingood+1
5369 ritz(ingood)=cg_ritz(i,outloop)
5370 ritzerr(ingood)=cg_ritzerr(i,outloop)
5371 END DO
5372 nconvritz=ingood
5373!
5374! Write out number of converged eigenvalues.
5375!
5376 SELECT CASE (hss(ng)%IOtype)
5377 CASE (io_nf90)
5378 CALL netcdf_put_ivar (ng, model, hss(ng)%name, &
5379 & 'nConvRitz', nconvritz, &
5380 & (/0/), (/0/), &
5381 & ncid = hss(ng)%ncid)
5382
5383# if defined PIO_LIB && defined DISTRIBUTE
5384 CASE (io_pio)
5385 CALL pio_netcdf_put_ivar (ng, model, hss(ng)%name, &
5386 & 'nConvRitz', nconvritz, &
5387 & (/0/), (/0/), &
5388 & piofile = hss(ng)%pioFile)
5389# endif
5390 END SELECT
5391 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
5392!
5393!-----------------------------------------------------------------------
5394! First, premultiply the converged eigenvectors of the tridiagonal
5395! matrix T(k) by the matrix of Lanczos vectors Q(k). Use tangent
5396! linear (index Lwrk) and adjoint (index Lold) state arrays as
5397! temporary storage.
5398!-----------------------------------------------------------------------
5399!
5400 IF (master) WRITE (stdout,10)
5401!
5402 columns : DO nvec=innloop,1,-1
5403!
5404! Initialize adjoint state arrays: ad_var(Lold) = fac
5405!
5406 fac=0.0_r8
5407
5408 CALL state_initialize (ng, tile, &
5409 & lbi, ubi, lbj, ubj, lbij, ubij, &
5410 & lold, fac, &
5411# ifdef MASKING
5412 & rmask, umask, vmask, &
5413# endif
5414# ifdef ADJUST_BOUNDARY
5415# ifdef SOLVE3D
5416 & ad_t_obc, ad_u_obc, ad_v_obc, &
5417# endif
5418 & ad_ubar_obc, ad_vbar_obc, &
5419 & ad_zeta_obc, &
5420# endif
5421# ifdef ADJUST_WSTRESS
5422 & ad_ustr, ad_vstr, &
5423# endif
5424# ifdef SOLVE3D
5425# ifdef ADJUST_STFLUX
5426 & ad_tflux, &
5427# endif
5428 & ad_t, ad_u, ad_v, &
5429# else
5430 & ad_ubar, ad_vbar, &
5431# endif
5432 & ad_zeta)
5433!
5434! Compute Hessian eigenvectors.
5435!
5436 IF (ndefadj(ng).gt.0) THEN
5437 WRITE (ncname,20) trim(adm(ng)%base), outloop
5438 ELSE
5439 ncname=adm(ng)%name
5440 END IF
5441!
5442 rows : DO rec=1,innloop
5443!
5444! Read gradient solution and load it into TANGENT LINEAR STATE ARRAYS
5445! at index Lwrk.
5446!
5447 CALL state_read (ng, tile, model, adm(ng)%IOtype, &
5448 & lbi, ubi, lbj, ubj, lbij, ubij, &
5449 & lwrk, rec, &
5450 & ndefadj(ng), adm(ng)%ncid, &
5451# if defined PIO_LIB && defined DISTRIBUTE
5452 & adm(ng)%pioFile, &
5453# endif
5454 & ncname, &
5455# ifdef MASKING
5456 & rmask, umask, vmask, &
5457# endif
5458# ifdef ADJUST_BOUNDARY
5459# ifdef SOLVE3D
5460 & tl_t_obc, tl_u_obc, tl_v_obc, &
5461# endif
5462 & tl_ubar_obc, tl_vbar_obc, &
5463 & tl_zeta_obc, &
5464# endif
5465# ifdef ADJUST_WSTRESS
5466 & tl_ustr, tl_vstr, &
5467# endif
5468# ifdef SOLVE3D
5469# ifdef ADJUST_STFLUX
5470 & tl_tflux, &
5471# endif
5472 & tl_t, tl_u, tl_v, &
5473# else
5474 & tl_ubar, tl_vbar, &
5475# endif
5476 & tl_zeta)
5477 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
5478!
5479! Compute Hessian eigenvectors:
5480!
5481! ad_var(Lold) = fac1 * ad_var(Lold) + fac2 * tl_var(Lwrk)
5482!
5483 fac1=1.0_r8
5484 fac2=cg_zv(rec,nvec)
5485
5486 CALL state_addition (ng, tile, &
5487 & lbi, ubi, lbj, ubj, lbij, ubij, &
5488 & lold, lwrk, lold, fac1, fac2, &
5489# ifdef MASKING
5490 & rmask, umask, vmask, &
5491# endif
5492# ifdef ADJUST_BOUNDARY
5493# ifdef SOLVE3D
5494 & ad_t_obc, tl_t_obc, &
5495 & ad_u_obc, tl_u_obc, &
5496 & ad_v_obc, tl_v_obc, &
5497# endif
5498 & ad_ubar_obc, tl_ubar_obc, &
5499 & ad_vbar_obc, tl_vbar_obc, &
5500 & ad_zeta_obc, tl_zeta_obc, &
5501# endif
5502# ifdef ADJUST_WSTRESS
5503 & ad_ustr, tl_ustr, &
5504 & ad_vstr, tl_vstr, &
5505# endif
5506# ifdef SOLVE3D
5507# ifdef ADJUST_STFLUX
5508 & ad_tflux, tl_tflux, &
5509# endif
5510 & ad_t, tl_t, &
5511 & ad_u, tl_u, &
5512 & ad_v, tl_v, &
5513# else
5514 & ad_ubar, tl_ubar, &
5515 & ad_vbar, tl_vbar, &
5516# endif
5517 & ad_zeta, tl_zeta)
5518 END DO rows
5519!
5520! Write eigenvectors into Hessian NetCDF.
5521!
5522 lwrtstate2d(ng)=.true.
5523# ifdef DISTRIBUTE
5524 CALL wrt_hessian (ng, myrank, lold, lold)
5525# else
5526 CALL wrt_hessian (ng, -1, lold, lold)
5527# endif
5528 lwrtstate2d(ng)=.false.
5529 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
5530
5531 END DO columns
5532!
5533!-----------------------------------------------------------------------
5534! Second, orthonormalize the converged Hessian vectors against each
5535! other. Use tangent linear state arrays (index Lwrk) as temporary
5536! storage.
5537!-----------------------------------------------------------------------
5538!
5539! Use nl_var(1) as temporary storage since we need to preserve
5540! ad_var(Lnew).
5541!
5542 IF (ndefadj(ng).gt.0) THEN
5543 WRITE (ncname,20) trim(hss(ng)%base), outloop
5544 ELSE
5545 ncname=hss(ng)%name
5546 END IF
5547 IF (master) WRITE (stdout,30)
5548!
5549 DO nvec=1,innloop
5550!
5551! Read in just computed Hessian eigenvectors into adjoint state array
5552! index Lold.
5553!
5554 CALL state_read (ng, tile, model, hss(ng)%IOtype, &
5555 & lbi, ubi, lbj, ubj, lbij, ubij, &
5556 & lold, nvec, &
5557 & 0, hss(ng)%ncid, &
5558# if defined PIO_LIB && defined DISTRIBUTE
5559 & hss(ng)%pioFile, &
5560# endif
5561 & ncname, &
5562# ifdef MASKING
5563 & rmask, umask, vmask, &
5564# endif
5565# ifdef ADJUST_BOUNDARY
5566# ifdef SOLVE3D
5567 & ad_t_obc, ad_u_obc, ad_v_obc, &
5568# endif
5569 & ad_ubar_obc, ad_vbar_obc, &
5570 & ad_zeta_obc, &
5571# endif
5572# ifdef ADJUST_WSTRESS
5573 & ad_ustr, ad_vstr, &
5574# endif
5575# ifdef SOLVE3D
5576# ifdef ADJUST_STFLUX
5577 & ad_tflux, &
5578# endif
5579 & ad_t, ad_u, ad_v, &
5580# else
5581 & ad_ubar, ad_vbar, &
5582# endif
5583 & ad_zeta)
5584 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
5585!
5586! Initialize nonlinear state arrays index L1 with just read Hessian
5587! vector in index Lold (initialize the summation):
5588!
5589! Copy ad_var(Lold) into nl_var(L1).
5590!
5591 l1=1
5592
5593 CALL state_copy (ng, tile, &
5594 & lbi, ubi, lbj, ubj, lbij, ubij, &
5595 & lold, l1, &
5596# ifdef ADJUST_BOUNDARY
5597# ifdef SOLVE3D
5598 & nl_t_obc, ad_t_obc, &
5599 & nl_u_obc, ad_u_obc, &
5600 & nl_v_obc, ad_v_obc, &
5601# endif
5602 & nl_ubar_obc, ad_ubar_obc, &
5603 & nl_vbar_obc, ad_vbar_obc, &
5604 & nl_zeta_obc, ad_zeta_obc, &
5605# endif
5606# ifdef ADJUST_WSTRESS
5607 & nl_ustr, ad_ustr, &
5608 & nl_vstr, ad_vstr, &
5609# endif
5610# ifdef SOLVE3D
5611# ifdef ADJUST_STFLUX
5612 & nl_tflux, ad_tflux, &
5613# endif
5614 & nl_t, ad_t, &
5615 & nl_u, ad_u, &
5616 & nl_v, ad_v, &
5617# else
5618 & nl_ubar, ad_ubar, &
5619 & nl_vbar, ad_vbar, &
5620# endif
5621 & nl_zeta, ad_zeta)
5622!
5623! Orthogonalize Hessian eigenvectors against each other.
5624!
5625 DO rec=1,nvec-1
5626!
5627! Read in gradient just computed Hessian eigenvectors into tangent
5628! linear state array index Lwrk.
5629!
5630 CALL state_read (ng, tile, model, hss(ng)%IOtype, &
5631 & lbi, ubi, lbj, ubj, lbij, ubij, &
5632 & lwrk, rec, &
5633 & 0, hss(ng)%ncid, &
5634# if defined PIO_LIB && defined DISTRIBUTE
5635 & hss(ng)%pioFile, &
5636# endif
5637 & ncname, &
5638# ifdef MASKING
5639 & rmask, umask, vmask, &
5640# endif
5641# ifdef ADJUST_BOUNDARY
5642# ifdef SOLVE3D
5643 & tl_t_obc, tl_u_obc, tl_v_obc, &
5644# endif
5645 & tl_ubar_obc, tl_vbar_obc, &
5646 & tl_zeta_obc, &
5647# endif
5648# ifdef ADJUST_WSTRESS
5649 & tl_ustr, tl_vstr, &
5650# endif
5651# ifdef SOLVE3D
5652# ifdef ADJUST_STFLUX
5653 & tl_tflux, &
5654# endif
5655 & tl_t, tl_u, tl_v, &
5656# else
5657 & tl_ubar, tl_vbar, &
5658# endif
5659 & tl_zeta)
5660 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
5661!
5662! Compute dot product.
5663!
5664 CALL state_dotprod (ng, tile, model, &
5665 & lbi, ubi, lbj, ubj, lbij, ubij, &
5666 & nstatevar(ng), dot(0:), &
5667# ifdef MASKING
5668 & rmask, umask, vmask, &
5669# endif
5670# ifdef ADJUST_BOUNDARY
5671# ifdef SOLVE3D
5672 & ad_t_obc(:,:,:,:,lold,:), &
5673 & tl_t_obc(:,:,:,:,lwrk,:), &
5674 & ad_u_obc(:,:,:,:,lold), &
5675 & tl_u_obc(:,:,:,:,lwrk), &
5676 & ad_v_obc(:,:,:,:,lold), &
5677 & tl_v_obc(:,:,:,:,lwrk), &
5678# endif
5679 & ad_ubar_obc(:,:,:,lold), &
5680 & tl_ubar_obc(:,:,:,lwrk), &
5681 & ad_vbar_obc(:,:,:,lold), &
5682 & tl_vbar_obc(:,:,:,lwrk), &
5683 & ad_zeta_obc(:,:,:,lold), &
5684 & tl_zeta_obc(:,:,:,lwrk), &
5685# endif
5686# ifdef ADJUST_WSTRESS
5687 & ad_ustr(:,:,:,lold), tl_ustr(:,:,:,lwrk), &
5688 & ad_vstr(:,:,:,lold), tl_vstr(:,:,:,lwrk), &
5689# endif
5690# ifdef SOLVE3D
5691# ifdef ADJUST_STFLUX
5692 & ad_tflux(:,:,:,lold,:), &
5693 & tl_tflux(:,:,:,lwrk,:), &
5694# endif
5695 & ad_t(:,:,:,lold,:), tl_t(:,:,:,lwrk,:), &
5696 & ad_u(:,:,:,lold), tl_u(:,:,:,lwrk), &
5697 & ad_v(:,:,:,lold), tl_v(:,:,:,lwrk), &
5698# else
5699 & ad_ubar(:,:,lold), tl_ubar(:,:,lwrk), &
5700 & ad_vbar(:,:,lold), tl_vbar(:,:,lwrk), &
5701# endif
5702 & ad_zeta(:,:,lold), tl_zeta(:,:,lwrk))
5703!
5704! Orthogonalize Hessian eigenvectors:
5705!
5706! nl_var(L1) = fac1 * nl_var(L1) + fac2 * tl_var(Lwrk)
5707!
5708 fac1=1.0_r8
5709 fac2=-dot(0)
5710
5711 CALL state_addition (ng, tile, &
5712 & lbi, ubi, lbj, ubj, lbij, ubij, &
5713 & l1, lwrk, l1, fac1, fac2, &
5714# ifdef MASKING
5715 & rmask, umask, vmask, &
5716# endif
5717# ifdef ADJUST_BOUNDARY
5718# ifdef SOLVE3D
5719 & nl_t_obc, tl_t_obc, &
5720 & nl_u_obc, tl_u_obc, &
5721 & nl_v_obc, tl_v_obc, &
5722# endif
5723 & nl_ubar_obc, tl_ubar_obc, &
5724 & nl_vbar_obc, tl_vbar_obc, &
5725 & nl_zeta_obc, tl_zeta_obc, &
5726# endif
5727# ifdef ADJUST_WSTRESS
5728 & nl_ustr, tl_ustr, &
5729 & nl_vstr, tl_vstr, &
5730# endif
5731# ifdef SOLVE3D
5732# ifdef ADJUST_STFLUX
5733 & nl_tflux, tl_tflux, &
5734# endif
5735 & nl_t, tl_t, &
5736 & nl_u, tl_u, &
5737 & nl_v, tl_v, &
5738# else
5739 & nl_ubar, tl_ubar, &
5740 & nl_vbar, tl_vbar, &
5741# endif
5742 & nl_zeta, tl_zeta)
5743 END DO
5744!
5745! Compute normalization factor.
5746!
5747 CALL state_dotprod (ng, tile, model, &
5748 & lbi, ubi, lbj, ubj, lbij, ubij, &
5749 & nstatevar(ng), dot(0:), &
5750# ifdef MASKING
5751 & rmask, umask, vmask, &
5752# endif
5753# ifdef ADJUST_BOUNDARY
5754# ifdef SOLVE3D
5755 & nl_t_obc(:,:,:,:,l1,:), &
5756 & nl_t_obc(:,:,:,:,l1,:), &
5757 & nl_u_obc(:,:,:,:,l1), &
5758 & nl_u_obc(:,:,:,:,l1), &
5759 & nl_v_obc(:,:,:,:,l1), &
5760 & nl_v_obc(:,:,:,:,l1), &
5761# endif
5762 & nl_ubar_obc(:,:,:,l1), &
5763 & nl_ubar_obc(:,:,:,l1), &
5764 & nl_vbar_obc(:,:,:,l1), &
5765 & nl_vbar_obc(:,:,:,l1), &
5766 & nl_zeta_obc(:,:,:,l1), &
5767 & nl_zeta_obc(:,:,:,l1), &
5768# endif
5769# ifdef ADJUST_WSTRESS
5770 & nl_ustr(:,:,:,l1), nl_ustr(:,:,:,l1), &
5771 & nl_vstr(:,:,:,l1), nl_vstr(:,:,:,l1), &
5772# endif
5773# ifdef SOLVE3D
5774# ifdef ADJUST_STFLUX
5775 & nl_tflux(:,:,:,l1,:), &
5776 & nl_tflux(:,:,:,l1,:), &
5777# endif
5778 & nl_t(:,:,:,l1,:), nl_t(:,:,:,l1,:), &
5779 & nl_u(:,:,:,l1), nl_u(:,:,:,l1), &
5780 & nl_v(:,:,:,l1), nl_v(:,:,:,l1), &
5781# else
5782 & nl_ubar(:,:,l1), nl_ubar(:,:,l1), &
5783 & nl_vbar(:,:,l1), nl_vbar(:,:,l1), &
5784# endif
5785 & nl_zeta(:,:,l1), nl_zeta(:,:,l1))
5786!
5787! Normalize Hessian eigenvectors:
5788!
5789! nl_var(L1) = fac * nl_var(L1)
5790!
5791 fac=1.0_r8/sqrt(dot(0))
5792
5793 CALL state_scale (ng, tile, &
5794 & lbi, ubi, lbj, ubj, lbij, ubij, &
5795 & l1, l1, fac, &
5796# ifdef MASKING
5797 & rmask, umask, vmask, &
5798# endif
5799# ifdef ADJUST_BOUNDARY
5800# ifdef SOLVE3D
5801 & nl_t_obc, nl_u_obc, nl_v_obc, &
5802# endif
5803 & nl_ubar_obc, nl_vbar_obc, &
5804 & nl_zeta_obc, &
5805# endif
5806# ifdef ADJUST_WSTRESS
5807 & nl_ustr, nl_vstr, &
5808# endif
5809# ifdef SOLVE3D
5810# ifdef ADJUST_STFLUX
5811 & nl_tflux, &
5812# endif
5813 & nl_t, nl_u, nl_v, &
5814# else
5815 & nl_ubar, nl_vbar, &
5816# endif
5817 & nl_zeta)
5818!
5819! Copy nl_var(L1) into ad_var(Lold).
5820!
5821 CALL state_copy (ng, tile, &
5822 & lbi, ubi, lbj, ubj, lbij, ubij, &
5823 & l1, lold, &
5824# ifdef ADJUST_BOUNDARY
5825# ifdef SOLVE3D
5826 & ad_t_obc, nl_t_obc, &
5827 & ad_u_obc, nl_u_obc, &
5828 & ad_v_obc, nl_v_obc, &
5829# endif
5830 & ad_ubar_obc, nl_ubar_obc, &
5831 & ad_vbar_obc, nl_vbar_obc, &
5832 & ad_zeta_obc, nl_zeta_obc, &
5833# endif
5834# ifdef ADJUST_WSTRESS
5835 & ad_ustr, nl_ustr, &
5836 & ad_vstr, nl_vstr, &
5837# endif
5838# ifdef SOLVE3D
5839# ifdef ADJUST_STFLUX
5840 & ad_tflux, nl_tflux, &
5841# endif
5842 & ad_t, nl_t, &
5843 & ad_u, nl_u, &
5844 & ad_v, nl_v, &
5845# else
5846 & ad_ubar, nl_ubar, &
5847 & ad_vbar, nl_vbar, &
5848# endif
5849 & ad_zeta, nl_zeta)
5850!
5851! Write out converged Ritz eigenvalues and is associated accuracy.
5852!
5853 SELECT CASE (hss(ng)%IOtype)
5854 CASE (io_nf90)
5855 CALL netcdf_put_fvar (ng, model, hss(ng)%name, &
5856 & 'Ritz', ritz(nvec:), &
5857 & (/nvec/), (/1/), &
5858 & ncid = hss(ng)%ncid)
5859 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
5860
5861 CALL netcdf_put_fvar (ng, model, hss(ng)%name, &
5862 & 'Ritz_error', ritzerr(nvec:), &
5863 & (/nvec/), (/1/), &
5864 & ncid = hss(ng)%ncid)
5865 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
5866
5867# if defined PIO_LIB && defined DISTRIBUTE
5868 CASE (io_pio)
5869 CALL pio_netcdf_put_fvar (ng, model, hss(ng)%name, &
5870 & 'Ritz', ritz(nvec:), &
5871 & (/nvec/), (/1/), &
5872 & piofile = hss(ng)%pioFile)
5873 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
5874
5875 CALL pio_netcdf_put_fvar (ng, model, hss(ng)%name, &
5876 & 'Ritz_error', ritzerr(nvec:), &
5877 & (/nvec/), (/1/), &
5878 & piofile = hss(ng)%pioFile)
5879 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
5880# endif
5881 END SELECT
5882!
5883! Replace record "nvec" of Hessian eigenvectors NetCDF with the
5884! normalized value in adjoint state arrays at index Lold.
5885!
5886 hss(ng)%Rindex=nvec-1
5887 lwrtstate2d(ng)=.true.
5888# ifdef DISTRIBUTE
5889 CALL wrt_hessian (ng, tile, lold, lold)
5890# else
5891 CALL wrt_hessian (ng, -1, lold, lold)
5892# endif
5893 lwrtstate2d(ng)=.false.
5894 IF (founderror(exit_flag, noerror, __line__, &
5895 & myfile)) RETURN
5896
5897 END DO
5898!
5899 10 FORMAT (/,' Computing converged Hessian eigenvectors...',/)
5900 20 FORMAT (a,'_',i3.3,'.nc')
5901 30 FORMAT (/,' Orthonormalizing converged Hessian eigenvectors...',/)
5902!
5903 RETURN

References mod_iounits::adm, mod_iounits::calledfrom, mod_fourdvar::cg_ritz, mod_fourdvar::cg_ritzerr, mod_fourdvar::cg_zv, mod_scalars::exit_flag, strings_mod::founderror(), mod_iounits::hss, mod_ncparam::io_nf90, mod_ncparam::io_pio, mod_stepping::lold, mod_scalars::lwrtstate2d, mod_parallel::master, mod_parallel::myrank, mod_fourdvar::nconvritz, mod_scalars::ndefadj, mod_scalars::noerror, mod_fourdvar::nstatevar, mod_fourdvar::ritz, mod_iounits::sourcefile, state_addition_mod::state_addition(), state_copy_mod::state_copy(), state_dotprod_mod::state_dotprod(), state_initialize_mod::state_initialize(), state_read_mod::state_read(), state_scale_mod::state_scale(), mod_iounits::stdout, and wrt_hessian_mod::wrt_hessian().

Referenced by cgradient_tile().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ lanczos()

subroutine, private cgradient_mod::lanczos ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) model,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
integer, intent(in) lbij,
integer, intent(in) ubij,
integer, intent(in) imins,
integer, intent(in) imaxs,
integer, intent(in) jmins,
integer, intent(in) jmaxs,
integer, intent(in) lold,
integer, intent(in) lnew,
integer, intent(in) lwrk,
integer, intent(in) innloop,
integer, intent(in) outloop,
real(r8), dimension(lbi:,lbj:), intent(in) rmask,
real(r8), dimension(lbi:,lbj:), intent(in) umask,
real(r8), dimension(lbi:,lbj:), intent(in) vmask,
real(r8), dimension(lbij:,:,:,:,:,:), intent(inout) tl_t_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) tl_u_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) tl_v_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) tl_ubar_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) tl_vbar_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) tl_zeta_obc,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) tl_ustr,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) tl_vstr,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) tl_tflux,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) tl_t,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) tl_u,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) tl_v,
real(r8), dimension(lbi:,lbj:,:), intent(inout) tl_zeta,
real(r8), dimension(lbij:,:,:,:,:,:), intent(inout) ad_t_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) ad_u_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) ad_v_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) ad_ubar_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) ad_vbar_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) ad_zeta_obc,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) ad_ustr,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) ad_vstr,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) ad_tflux,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) ad_t,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) ad_u,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) ad_v,
real(r8), dimension(lbi:,lbj:,:), intent(inout) ad_zeta )
private

Definition at line 3916 of file cgradient.F.

3962!***********************************************************************
3963!
3964! Imported variable declarations.
3965!
3966 integer, intent(in) :: ng, tile, model
3967 integer, intent(in) :: LBi, UBi, LBj, UBj, LBij, UBij
3968 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
3969 integer, intent(in) :: Lold, Lnew, Lwrk
3970 integer, intent(in) :: innLoop, outLoop
3971!
3972# ifdef ASSUMED_SHAPE
3973# ifdef MASKING
3974 real(r8), intent(in) :: rmask(LBi:,LBj:)
3975 real(r8), intent(in) :: umask(LBi:,LBj:)
3976 real(r8), intent(in) :: vmask(LBi:,LBj:)
3977# endif
3978# ifdef ADJUST_BOUNDARY
3979# ifdef SOLVE3D
3980 real(r8), intent(inout) :: ad_t_obc(LBij:,:,:,:,:,:)
3981 real(r8), intent(inout) :: ad_u_obc(LBij:,:,:,:,:)
3982 real(r8), intent(inout) :: ad_v_obc(LBij:,:,:,:,:)
3983# endif
3984 real(r8), intent(inout) :: ad_ubar_obc(LBij:,:,:,:)
3985 real(r8), intent(inout) :: ad_vbar_obc(LBij:,:,:,:)
3986 real(r8), intent(inout) :: ad_zeta_obc(LBij:,:,:,:)
3987# endif
3988# ifdef ADJUST_WSTRESS
3989 real(r8), intent(inout) :: ad_ustr(LBi:,LBj:,:,:)
3990 real(r8), intent(inout) :: ad_vstr(LBi:,LBj:,:,:)
3991# endif
3992# ifdef SOLVE3D
3993# ifdef ADJUST_STFLUX
3994 real(r8), intent(inout) :: ad_tflux(LBi:,LBj:,:,:,:)
3995# endif
3996 real(r8), intent(inout) :: ad_t(LBi:,LBj:,:,:,:)
3997 real(r8), intent(inout) :: ad_u(LBi:,LBj:,:,:)
3998 real(r8), intent(inout) :: ad_v(LBi:,LBj:,:,:)
3999# else
4000 real(r8), intent(inout) :: ad_ubar(LBi:,LBj:,:)
4001 real(r8), intent(inout) :: ad_vbar(LBi:,LBj:,:)
4002# endif
4003 real(r8), intent(inout) :: ad_zeta(LBi:,LBj:,:)
4004# ifdef ADJUST_BOUNDARY
4005# ifdef SOLVE3D
4006 real(r8), intent(inout) :: tl_t_obc(LBij:,:,:,:,:,:)
4007 real(r8), intent(inout) :: tl_u_obc(LBij:,:,:,:,:)
4008 real(r8), intent(inout) :: tl_v_obc(LBij:,:,:,:,:)
4009# endif
4010 real(r8), intent(inout) :: tl_ubar_obc(LBij:,:,:,:)
4011 real(r8), intent(inout) :: tl_vbar_obc(LBij:,:,:,:)
4012 real(r8), intent(inout) :: tl_zeta_obc(LBij:,:,:,:)
4013# endif
4014# ifdef ADJUST_WSTRESS
4015 real(r8), intent(inout) :: tl_ustr(LBi:,LBj:,:,:)
4016 real(r8), intent(inout) :: tl_vstr(LBi:,LBj:,:,:)
4017# endif
4018# ifdef SOLVE3D
4019# ifdef ADJUST_STFLUX
4020 real(r8), intent(inout) :: tl_tflux(LBi:,LBj:,:,:,:)
4021# endif
4022 real(r8), intent(inout) :: tl_t(LBi:,LBj:,:,:,:)
4023 real(r8), intent(inout) :: tl_u(LBi:,LBj:,:,:)
4024 real(r8), intent(inout) :: tl_v(LBi:,LBj:,:,:)
4025# else
4026 real(r8), intent(inout) :: tl_ubar(LBi:,LBj:,:)
4027 real(r8), intent(inout) :: tl_vbar(LBi:,LBj:,:)
4028# endif
4029 real(r8), intent(inout) :: tl_zeta(LBi:,LBj:,:)
4030
4031# else
4032
4033# ifdef MASKING
4034 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
4035 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
4036 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
4037# endif
4038# ifdef ADJUST_BOUNDARY
4039# ifdef SOLVE3D
4040 real(r8), intent(inout) :: ad_t_obc(LBij:UBij,N(ng),4, &
4041 & Nbrec(ng),2,NT(ng))
4042 real(r8), intent(inout) :: ad_u_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
4043 real(r8), intent(inout) :: ad_v_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
4044# endif
4045 real(r8), intent(inout) :: ad_ubar_obc(LBij:UBij,4,Nbrec(ng),2)
4046 real(r8), intent(inout) :: ad_vbar_obc(LBij:UBij,4,Nbrec(ng),2)
4047 real(r8), intent(inout) :: ad_zeta_obc(LBij:UBij,4,Nbrec(ng),2)
4048# endif
4049# ifdef ADJUST_WSTRESS
4050 real(r8), intent(inout) :: ad_ustr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
4051 real(r8), intent(inout) :: ad_vstr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
4052# endif
4053# ifdef SOLVE3D
4054# ifdef ADJUST_STFLUX
4055 real(r8), intent(inout) :: ad_tflux(LBi:UBi,LBj:UBj, &
4056 & Nfrec(ng),2,NT(ng))
4057# endif
4058 real(r8), intent(inout) :: ad_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
4059 real(r8), intent(inout) :: ad_u(LBi:UBi,LBj:UBj,N(ng),2)
4060 real(r8), intent(inout) :: ad_v(LBi:UBi,LBj:UBj,N(ng),2)
4061# else
4062 real(r8), intent(inout) :: ad_ubar(LBi:UBi,LBj:UBj,:)
4063 real(r8), intent(inout) :: ad_vbar(LBi:UBi,LBj:UBj,:)
4064# endif
4065 real(r8), intent(inout) :: ad_zeta(LBi:UBi,LBj:UBj,:)
4066# ifdef ADJUST_BOUNDARY
4067# ifdef SOLVE3D
4068 real(r8), intent(inout) :: tl_t_obc(LBij:UBij,N(ng),4, &
4069 & Nbrec(ng),2,NT(ng))
4070 real(r8), intent(inout) :: tl_u_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
4071 real(r8), intent(inout) :: tl_v_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
4072# endif
4073 real(r8), intent(inout) :: tl_ubar_obc(LBij:UBij,4,Nbrec(ng),2)
4074 real(r8), intent(inout) :: tl_vbar_obc(LBij:UBij,4,Nbrec(ng),2)
4075 real(r8), intent(inout) :: tl_zeta_obc(LBij:UBij,4,Nbrec(ng),2)
4076# endif
4077# ifdef ADJUST_WSTRESS
4078 real(r8), intent(inout) :: tl_ustr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
4079 real(r8), intent(inout) :: tl_vstr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
4080# endif
4081# ifdef SOLVE3D
4082# ifdef ADJUST_STFLUX
4083 real(r8), intent(inout) :: tl_tflux(LBi:UBi,LBj:UBj, &
4084 & Nfrec(ng),2,NT(ng))
4085# endif
4086 real(r8), intent(inout) :: tl_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
4087 real(r8), intent(inout) :: tl_u(LBi:UBi,LBj:UBj,N(ng),2)
4088 real(r8), intent(inout) :: tl_v(LBi:UBi,LBj:UBj,N(ng),2)
4089# else
4090 real(r8), intent(inout) :: tl_ubar(LBi:UBi,LBj:UBj,:)
4091 real(r8), intent(inout) :: tl_vbar(LBi:UBi,LBj:UBj,:)
4092# endif
4093 real(r8), intent(inout) :: tl_zeta(LBi:UBi,LBj:UBj,:)
4094# endif
4095!
4096! Local variable declarations.
4097!
4098 integer :: i, j, rec
4099!
4100 real(r8) :: fac, fac1, fac2
4101
4102 real(r8), dimension(0:NstateVar(ng)) :: dot
4103 real(r8), dimension(0:Ninner) :: DotProd, dot_new, dot_old
4104!
4105 character (len=256) :: ncname
4106
4107 character (len=*), parameter :: MyFile = &
4108 & __FILE__//", lanczos"
4109
4110# include "set_bounds.h"
4111!
4112 calledfrom=myfile
4113 sourcefile=myfile
4114!
4115!-----------------------------------------------------------------------
4116! Calculate the new Lanczos vector, q(k+1) using reccurence equation
4117! for the gradient vectors:
4118!
4119! H q(k+1) = Gamma(k+1) q(k+2) + Delta(k+1) q(k+1) + Gamma(k) q(k)
4120!
4121! where Gamma(k) = - SQRT ( Beta(k+1) ) / Alpha(k)
4122!-----------------------------------------------------------------------
4123!
4124! At this point, the previous orthonormal Lanczos vector is still in
4125! tangent linear state arrays (index Lwrk) - it was read in the
4126! routine hessian.
4127!
4128 IF (innloop.gt.0) THEN
4129!
4130! Compute new Lanczos vector:
4131!
4132! ad_var(Lnew) = fac1 * ad_var(Lnew) + fac2 * tl_var(Lwrk)
4133!
4134 fac1=1.0_r8
4135 fac2=-cg_delta(innloop,outloop)
4136
4137 CALL state_addition (ng, tile, &
4138 & lbi, ubi, lbj, ubj, lbij, ubij, &
4139 & lnew, lwrk, lnew, fac1, fac2, &
4140# ifdef MASKING
4141 & rmask, umask, vmask, &
4142# endif
4143# ifdef ADJUST_BOUNDARY
4144# ifdef SOLVE3D
4145 & ad_t_obc, tl_t_obc, &
4146 & ad_u_obc, tl_u_obc, &
4147 & ad_v_obc, tl_v_obc, &
4148# endif
4149 & ad_ubar_obc, tl_ubar_obc, &
4150 & ad_vbar_obc, tl_vbar_obc, &
4151 & ad_zeta_obc, tl_zeta_obc, &
4152# endif
4153# ifdef ADJUST_WSTRESS
4154 & ad_ustr, tl_ustr, &
4155 & ad_vstr, tl_vstr, &
4156# endif
4157# ifdef SOLVE3D
4158# ifdef ADJUST_STFLUX
4159 & ad_tflux, tl_tflux, &
4160# endif
4161 & ad_t, tl_t, &
4162 & ad_u, tl_u, &
4163 & ad_v, tl_v, &
4164# else
4165 & ad_ubar, tl_ubar, &
4166 & ad_vbar, tl_vbar, &
4167# endif
4168 & ad_zeta, tl_zeta)
4169 END IF
4170!
4171! Substract previous orthonormal Lanczos vector.
4172!
4173 IF (innloop.gt.1) THEN
4174!
4175! Determine adjoint file to process.
4176!
4177 IF (ndefadj(ng).gt.0) THEN
4178 WRITE (ncname,10) trim(adm(ng)%base), outloop
4179 10 FORMAT (a,'_',i3.3,'.nc')
4180 ELSE
4181 ncname=adm(ng)%name
4182 END IF
4183!
4184! Read in the previous (innLoop-1) orthonormal Lanczos vector.
4185!
4186 CALL state_read (ng, tile, model, adm(ng)%IOtype, &
4187 & lbi, ubi, lbj, ubj, lbij, ubij, &
4188 & lwrk, innloop-1, &
4189 & ndefadj(ng), adm(ng)%ncid, &
4190# if defined PIO_LIB && defined DISTRIBUTE
4191 & adm(ng)%pioFile, &
4192# endif
4193 & ncname, &
4194# ifdef MASKING
4195 & rmask, umask, vmask, &
4196# endif
4197# ifdef ADJUST_BOUNDARY
4198# ifdef SOLVE3D
4199 & tl_t_obc, tl_u_obc, tl_v_obc, &
4200# endif
4201 & tl_ubar_obc, tl_vbar_obc, &
4202 & tl_zeta_obc, &
4203# endif
4204# ifdef ADJUST_WSTRESS
4205 & tl_ustr, tl_vstr, &
4206# endif
4207# ifdef SOLVE3D
4208# ifdef ADJUST_STFLUX
4209 & tl_tflux, &
4210# endif
4211 & tl_t, tl_u, tl_v, &
4212# else
4213 & tl_ubar, tl_vbar, &
4214# endif
4215 & tl_zeta)
4216 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4217!
4218! Substract previous orthonormal Lanczos vector:
4219!
4220! ad_var(Lnew) = fac1 * ad_var(Lnew) + fac2 * tl_var(Lwrk)
4221!
4222 fac1=1.0_r8
4223 fac2=-cg_beta(innloop,outloop)
4224
4225 CALL state_addition (ng, tile, &
4226 & lbi, ubi, lbj, ubj, lbij, ubij, &
4227 & lnew, lwrk, lnew, fac1, fac2, &
4228# ifdef MASKING
4229 & rmask, umask, vmask, &
4230# endif
4231# ifdef ADJUST_BOUNDARY
4232# ifdef SOLVE3D
4233 & ad_t_obc, tl_t_obc, &
4234 & ad_u_obc, tl_u_obc, &
4235 & ad_v_obc, tl_v_obc, &
4236# endif
4237 & ad_ubar_obc, tl_ubar_obc, &
4238 & ad_vbar_obc, tl_vbar_obc, &
4239 & ad_zeta_obc, tl_zeta_obc, &
4240# endif
4241# ifdef ADJUST_WSTRESS
4242 & ad_ustr, tl_ustr, &
4243 & ad_vstr, tl_vstr, &
4244# endif
4245# ifdef SOLVE3D
4246# ifdef ADJUST_STFLUX
4247 & ad_tflux, tl_tflux, &
4248# endif
4249 & ad_t, tl_t, &
4250 & ad_u, tl_u, &
4251 & ad_v, tl_v, &
4252# else
4253 & ad_ubar, tl_ubar, &
4254 & ad_vbar, tl_vbar, &
4255# endif
4256 & ad_zeta, tl_zeta)
4257 END IF
4258!
4259!-----------------------------------------------------------------------
4260! Orthogonalize current gradient, q(k+1), against all previous
4261! gradients (reverse order) using Gramm-Schmidt procedure.
4262!-----------------------------------------------------------------------
4263!
4264! We can overwrite adjoint arrays at index Lnew each time around the
4265! the following loop because the preceding gradient vectors that we
4266! read are orthogonal to each other. The reversed order of the loop
4267! is important for the Lanczos vector calculations.
4268!
4269 IF (ndefadj(ng).gt.0) THEN
4270 WRITE (ncname,10) trim(adm(ng)%base), outloop
4271 ELSE
4272 ncname=adm(ng)%name
4273 END IF
4274!
4275 DO rec=innloop,1,-1
4276!
4277! Read in each previous gradient state solutions, G(0) to G(k), and
4278! compute its associated dot angaint curret G(k+1). Each gradient
4279! solution is loaded into TANGENT LINEAR STATE ARRAYS at index Lwrk.
4280!
4281 CALL state_read (ng, tile, model, adm(ng)%IOtype, &
4282 & lbi, ubi, lbj, ubj, lbij, ubij, &
4283 & lwrk, rec, &
4284 & ndefadj(ng), adm(ng)%ncid, &
4285# if defined PIO_LIB && defined DISTRIBUTE
4286 & adm(ng)%pioFile, &
4287# endif
4288 & ncname, &
4289# ifdef MASKING
4290 & rmask, umask, vmask, &
4291# endif
4292# ifdef ADJUST_BOUNDARY
4293# ifdef SOLVE3D
4294 & tl_t_obc, tl_u_obc, tl_v_obc, &
4295# endif
4296 & tl_ubar_obc, tl_vbar_obc, &
4297 & tl_zeta_obc, &
4298# endif
4299# ifdef ADJUST_WSTRESS
4300 & tl_ustr, tl_vstr, &
4301# endif
4302# ifdef SOLVE3D
4303# ifdef ADJUST_STFLUX
4304 & tl_tflux, &
4305# endif
4306 & tl_t, tl_u, tl_v, &
4307# else
4308 & tl_ubar, tl_vbar, &
4309# endif
4310 & tl_zeta)
4311 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4312!
4313! Compute dot product <q(k+1), q(rec)>.
4314!
4315 CALL state_dotprod (ng, tile, model, &
4316 & lbi, ubi, lbj, ubj, lbij, ubij, &
4317 & nstatevar(ng), dot(0:), &
4318# ifdef MASKING
4319 & rmask, umask, vmask, &
4320# endif
4321# ifdef ADJUST_BOUNDARY
4322# ifdef SOLVE3D
4323 & ad_t_obc(:,:,:,:,lnew,:), &
4324 & tl_t_obc(:,:,:,:,lwrk,:), &
4325 & ad_u_obc(:,:,:,:,lnew), &
4326 & tl_u_obc(:,:,:,:,lwrk), &
4327 & ad_v_obc(:,:,:,:,lnew), &
4328 & tl_v_obc(:,:,:,:,lwrk), &
4329# endif
4330 & ad_ubar_obc(:,:,:,lnew), &
4331 & tl_ubar_obc(:,:,:,lwrk), &
4332 & ad_vbar_obc(:,:,:,lnew), &
4333 & tl_vbar_obc(:,:,:,lwrk), &
4334 & ad_zeta_obc(:,:,:,lnew), &
4335 & tl_zeta_obc(:,:,:,lwrk), &
4336# endif
4337# ifdef ADJUST_WSTRESS
4338 & ad_ustr(:,:,:,lnew), tl_ustr(:,:,:,lwrk), &
4339 & ad_vstr(:,:,:,lnew), tl_vstr(:,:,:,lwrk), &
4340# endif
4341# ifdef SOLVE3D
4342# ifdef ADJUST_STFLUX
4343 & ad_tflux(:,:,:,lnew,:), &
4344 & tl_tflux(:,:,:,lwrk,:), &
4345# endif
4346 & ad_t(:,:,:,lnew,:), tl_t(:,:,:,lwrk,:), &
4347 & ad_u(:,:,:,lnew), tl_u(:,:,:,lwrk), &
4348 & ad_v(:,:,:,lnew), tl_v(:,:,:,lwrk), &
4349# else
4350 & ad_ubar(:,:,lnew), tl_ubar(:,:,lwrk), &
4351 & ad_vbar(:,:,lnew), tl_vbar(:,:,lwrk), &
4352# endif
4353 & ad_zeta(:,:,lnew), tl_zeta(:,:,lwrk))
4354!
4355! Compute Gramm-Schmidt scaling coefficient.
4356!
4357 dotprod(rec)=dot(0)
4358!
4359! Gramm-Schmidt orthonormalization, free-surface.
4360!
4361! ad_var(Lnew) = fac1 * ad_var(Lnew) + fac2 * tl_var(Lwrk)
4362!
4363 fac1=1.0_r8
4364 fac2=-dotprod(rec)
4365
4366 CALL state_addition (ng, tile, &
4367 & lbi, ubi, lbj, ubj, lbij, ubij, &
4368 & lnew, lwrk, lnew, fac1, fac2, &
4369# ifdef MASKING
4370 & rmask, umask, vmask, &
4371# endif
4372# ifdef ADJUST_BOUNDARY
4373# ifdef SOLVE3D
4374 & ad_t_obc, tl_t_obc, &
4375 & ad_u_obc, tl_u_obc, &
4376 & ad_v_obc, tl_v_obc, &
4377# endif
4378 & ad_ubar_obc, tl_ubar_obc, &
4379 & ad_vbar_obc, tl_vbar_obc, &
4380 & ad_zeta_obc, tl_zeta_obc, &
4381# endif
4382# ifdef ADJUST_WSTRESS
4383 & ad_ustr, tl_ustr, &
4384 & ad_vstr, tl_vstr, &
4385# endif
4386# ifdef SOLVE3D
4387# ifdef ADJUST_STFLUX
4388 & ad_tflux, tl_tflux, &
4389# endif
4390 & ad_t, tl_t, &
4391 & ad_u, tl_u, &
4392 & ad_v, tl_v, &
4393# else
4394 & ad_ubar, tl_ubar, &
4395 & ad_vbar, tl_vbar, &
4396# endif
4397 & ad_zeta, tl_zeta)
4398 END DO
4399!
4400!-----------------------------------------------------------------------
4401! Normalize current orthogonal gradient vector.
4402!-----------------------------------------------------------------------
4403!
4404 CALL state_dotprod (ng, tile, model, &
4405 & lbi, ubi, lbj, ubj, lbij, ubij, &
4406 & nstatevar(ng), dot(0:), &
4407# ifdef MASKING
4408 & rmask, umask, vmask, &
4409# endif
4410# ifdef ADJUST_BOUNDARY
4411# ifdef SOLVE3D
4412 & ad_t_obc(:,:,:,:,lnew,:), &
4413 & ad_t_obc(:,:,:,:,lnew,:), &
4414 & ad_u_obc(:,:,:,:,lnew), &
4415 & ad_u_obc(:,:,:,:,lnew), &
4416 & ad_v_obc(:,:,:,:,lnew), &
4417 & ad_v_obc(:,:,:,:,lnew), &
4418# endif
4419 & ad_ubar_obc(:,:,:,lnew), &
4420 & ad_ubar_obc(:,:,:,lnew), &
4421 & ad_vbar_obc(:,:,:,lnew), &
4422 & ad_vbar_obc(:,:,:,lnew), &
4423 & ad_zeta_obc(:,:,:,lnew), &
4424 & ad_zeta_obc(:,:,:,lnew), &
4425# endif
4426# ifdef ADJUST_WSTRESS
4427 & ad_ustr(:,:,:,lnew), ad_ustr(:,:,:,lnew), &
4428 & ad_vstr(:,:,:,lnew), ad_vstr(:,:,:,lnew), &
4429# endif
4430# ifdef SOLVE3D
4431# ifdef ADJUST_STFLUX
4432 & ad_tflux(:,:,:,lnew,:), &
4433 & ad_tflux(:,:,:,lnew,:), &
4434# endif
4435 & ad_t(:,:,:,lnew,:), ad_t(:,:,:,lnew,:), &
4436 & ad_u(:,:,:,lnew), ad_u(:,:,:,lnew), &
4437 & ad_v(:,:,:,lnew), ad_v(:,:,:,lnew), &
4438# else
4439 & ad_ubar(:,:,lnew), ad_ubar(:,:,lnew), &
4440 & ad_vbar(:,:,lnew), ad_vbar(:,:,lnew), &
4441# endif
4442 & ad_zeta(:,:,lnew), ad_zeta(:,:,lnew))
4443!
4444! Compute normalization factor.
4445!
4446 IF (innloop.eq.0) THEN
4447 cg_gnorm(outloop)=sqrt(dot(0))
4448 ELSE
4449 cg_beta(innloop+1,outloop)=sqrt(dot(0))
4450 END IF
4451!
4452! Normalize gradient: ad_var(Lnew) = fac * ad_var(Lnew)
4453!
4454 fac=1.0_r8/sqrt(dot(0))
4455
4456 CALL state_scale (ng, tile, &
4457 & lbi, ubi, lbj, ubj, lbij, ubij, &
4458 & lnew, lnew, fac, &
4459# ifdef MASKING
4460 & rmask, umask, vmask, &
4461# endif
4462# ifdef ADJUST_BOUNDARY
4463# ifdef SOLVE3D
4464 & ad_t_obc, ad_u_obc, ad_v_obc, &
4465# endif
4466 & ad_ubar_obc, ad_vbar_obc, &
4467 & ad_zeta_obc, &
4468# endif
4469# ifdef ADJUST_WSTRESS
4470 & ad_ustr, ad_vstr, &
4471# endif
4472# ifdef SOLVE3D
4473# ifdef ADJUST_STFLUX
4474 & ad_tflux, &
4475# endif
4476 & ad_t, ad_u, ad_v, &
4477# else
4478 & ad_ubar, ad_vbar, &
4479# endif
4480 & ad_zeta)
4481!
4482!-----------------------------------------------------------------------
4483! Compute dot product of new Lanczos vector with gradient.
4484!-----------------------------------------------------------------------
4485!
4486 IF (innloop.eq.0) THEN
4487 CALL state_dotprod (ng, tile, model, &
4488 & lbi, ubi, lbj, ubj, lbij, ubij, &
4489 & nstatevar(ng), dot(0:), &
4490# ifdef MASKING
4491 & rmask, umask, vmask, &
4492# endif
4493# ifdef ADJUST_BOUNDARY
4494# ifdef SOLVE3D
4495 & ad_t_obc(:,:,:,:,lnew,:), &
4496 & ad_t_obc(:,:,:,:,lnew,:), &
4497 & ad_u_obc(:,:,:,:,lnew), &
4498 & ad_u_obc(:,:,:,:,lnew), &
4499 & ad_v_obc(:,:,:,:,lnew), &
4500 & ad_v_obc(:,:,:,:,lnew), &
4501# endif
4502 & ad_ubar_obc(:,:,:,lnew), &
4503 & ad_ubar_obc(:,:,:,lnew), &
4504 & ad_vbar_obc(:,:,:,lnew), &
4505 & ad_vbar_obc(:,:,:,lnew), &
4506 & ad_zeta_obc(:,:,:,lnew), &
4507 & ad_zeta_obc(:,:,:,lnew), &
4508# endif
4509# ifdef ADJUST_WSTRESS
4510 & ad_ustr(:,:,:,lnew), ad_ustr(:,:,:,lnew), &
4511 & ad_vstr(:,:,:,lnew), ad_vstr(:,:,:,lnew), &
4512# endif
4513# ifdef SOLVE3D
4514# ifdef ADJUST_STFLUX
4515 & ad_tflux(:,:,:,lnew,:), &
4516 & ad_tflux(:,:,:,lnew,:), &
4517# endif
4518 & ad_t(:,:,:,lnew,:), ad_t(:,:,:,lnew,:), &
4519 & ad_u(:,:,:,lnew), ad_u(:,:,:,lnew), &
4520 & ad_v(:,:,:,lnew), ad_v(:,:,:,lnew), &
4521# else
4522 & ad_ubar(:,:,lnew), ad_ubar(:,:,lnew), &
4523 & ad_vbar(:,:,lnew), ad_vbar(:,:,lnew), &
4524# endif
4525 & ad_zeta(:,:,lnew), ad_zeta(:,:,lnew))
4526 ELSE
4527 CALL state_dotprod (ng, tile, model, &
4528 & lbi, ubi, lbj, ubj, lbij, ubij, &
4529 & nstatevar(ng), dot(0:), &
4530# ifdef MASKING
4531 & rmask, umask, vmask, &
4532# endif
4533# ifdef ADJUST_BOUNDARY
4534# ifdef SOLVE3D
4535 & ad_t_obc(:,:,:,:,lold,:), &
4536 & ad_t_obc(:,:,:,:,lnew,:), &
4537 & ad_u_obc(:,:,:,:,lold), &
4538 & ad_u_obc(:,:,:,:,lnew), &
4539 & ad_v_obc(:,:,:,:,lold), &
4540 & ad_v_obc(:,:,:,:,lnew), &
4541# endif
4542 & ad_ubar_obc(:,:,:,lold), &
4543 & ad_ubar_obc(:,:,:,lnew), &
4544 & ad_vbar_obc(:,:,:,lold), &
4545 & ad_vbar_obc(:,:,:,lnew), &
4546 & ad_zeta_obc(:,:,:,lold), &
4547 & ad_zeta_obc(:,:,:,lnew), &
4548# endif
4549# ifdef ADJUST_WSTRESS
4550 & ad_ustr(:,:,:,lold), ad_ustr(:,:,:,lnew), &
4551 & ad_vstr(:,:,:,lold), ad_vstr(:,:,:,lnew), &
4552# endif
4553# ifdef SOLVE3D
4554# ifdef ADJUST_STFLUX
4555 & ad_tflux(:,:,:,lold,:), &
4556 & ad_tflux(:,:,:,lnew,:), &
4557# endif
4558 & ad_t(:,:,:,lold,:), ad_t(:,:,:,lnew,:), &
4559 & ad_u(:,:,:,lold), ad_u(:,:,:,lnew), &
4560 & ad_v(:,:,:,lold), ad_v(:,:,:,lnew), &
4561# else
4562 & ad_ubar(:,:,lold), ad_ubar(:,:,lnew), &
4563 & ad_vbar(:,:,lold), ad_vbar(:,:,lnew), &
4564# endif
4565 & ad_zeta(:,:,lold), ad_zeta(:,:,lnew))
4566 ENDIF
4567!
4568! Need to multiply dot(0) by zgnorm because the gradient (index Lold)
4569! has been normalized.
4570!
4571 cg_qg(innloop+1,outloop)=cg_gnorm(outloop)*dot(0)
4572
4573# ifdef TEST_ORTHOGONALIZATION
4574!
4575!-----------------------------------------------------------------------
4576! Test orthogonal properties of the new gradient.
4577!-----------------------------------------------------------------------
4578!
4579! Determine adjoint file to process.
4580!
4581 IF (ndefadj(ng).gt.0) THEN
4582 WRITE (ncname,10) trim(adm(ng)%base), outloop
4583 ELSE
4584 ncname=adm(ng)%name
4585 END IF
4586!
4587 DO rec=innloop,1,-1
4588!
4589! Read in each previous gradient state solutions, q(0) to q(k), and
4590! compute its associated dot angaint orthogonalized q(k+1). Again,
4591! each gradient solution is loaded into TANGENT LINEAR STATE ARRAYS
4592! at index Lwrk.
4593!
4594 CALL state_read (ng, tile, model, adm(ng)%IOtype, &
4595 & lbi, ubi, lbj, ubj, lbij, ubij, &
4596 & lwrk, rec, &
4597 & ndefadj(ng), adm(ng)%ncid, &
4598# if defined PIO_LIB && defined DISTRIBUTE
4599 & adm(ng)%pioFile, &
4600# endif
4601 & ncname, &
4602# ifdef MASKING
4603 & rmask, umask, vmask, &
4604# endif
4605# ifdef ADJUST_BOUNDARY
4606# ifdef SOLVE3D
4607 & tl_t_obc, tl_u_obc, tl_v_obc, &
4608# endif
4609 & tl_ubar_obc, tl_vbar_obc, &
4610 & tl_zeta_obc, &
4611# endif
4612# ifdef ADJUST_WSTRESS
4613 & tl_ustr, tl_vstr, &
4614# endif
4615# ifdef SOLVE3D
4616# ifdef ADJUST_STFLUX
4617 & tl_tflux, &
4618# endif
4619 & tl_t, tl_u, tl_v, &
4620# else
4621 & tl_ubar, tl_vbar, &
4622# endif
4623 & tl_zeta)
4624 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4625!
4626 CALL state_dotprod (ng, tile, model, &
4627 & lbi, ubi, lbj, ubj, lbij, ubij, &
4628 & nstatevar(ng), dot(0:), &
4629# ifdef MASKING
4630 & rmask, umask, vmask, &
4631# endif
4632# ifdef ADJUST_BOUNDARY
4633# ifdef SOLVE3D
4634 & ad_t_obc(:,:,:,:,lnew,:), &
4635 & tl_t_obc(:,:,:,:,lwrk,:), &
4636 & ad_u_obc(:,:,:,:,lnew), &
4637 & tl_u_obc(:,:,:,:,lwrk), &
4638 & ad_v_obc(:,:,:,:,lnew), &
4639 & tl_v_obc(:,:,:,:,lwrk), &
4640# endif
4641 & ad_ubar_obc(:,:,:,lnew), &
4642 & tl_ubar_obc(:,:,:,lwrk), &
4643 & ad_vbar_obc(:,:,:,lnew), &
4644 & tl_vbar_obc(:,:,:,lwrk), &
4645 & ad_zeta_obc(:,:,:,lnew), &
4646 & tl_zeta_obc(:,:,:,lwrk), &
4647# endif
4648# ifdef ADJUST_WSTRESS
4649 & ad_ustr(:,:,:,lnew), tl_ustr(:,:,:,lwrk), &
4650 & ad_vstr(:,:,:,lnew), tl_vstr(:,:,:,lwrk), &
4651# endif
4652# ifdef SOLVE3D
4653# ifdef ADJUST_STFLUX
4654 & ad_tflux(:,:,:,lnew,:), &
4655 & tl_tflux(:,:,:,lwrk,:), &
4656# endif
4657 & ad_t(:,:,:,lnew,:), tl_t(:,:,:,lwrk,:), &
4658 & ad_u(:,:,:,lnew), tl_u(:,:,:,lwrk), &
4659 & ad_v(:,:,:,lnew), tl_v(:,:,:,lwrk), &
4660# else
4661 & ad_ubar(:,:,lnew), tl_ubar(:,:,lwrk), &
4662 & ad_vbar(:,:,lnew), tl_vbar(:,:,lwrk), &
4663# endif
4664 & ad_zeta(:,:,lnew), tl_zeta(:,:,lwrk))
4665 dot_new(rec)=dot(0)
4666 END DO
4667!
4668! Report dot products. If everything is working correctly, at the
4669! end of the orthogonalization dot_new(rec) << dot_old(rec).
4670!
4671 IF (master) THEN
4672 WRITE (stdout,20) outloop, innloop
4673 DO rec=innloop,1,-1
4674 WRITE (stdout,30) dotprod(rec), rec-1
4675 END DO
4676 WRITE (stdout,*) ' '
4677 DO rec=innloop,1,-1
4678 WRITE (stdout,40) innloop, rec-1, dot_new(rec), &
4679 & rec-1, rec-1, dot_old(rec)
4680 END DO
4681 20 FORMAT (/,1x,'(',i3.3,',',i3.3,'): ', &
4682 & 'Gramm-Schmidt Orthogonalization:',/)
4683 30 FORMAT (12x,'Orthogonalization Factor = ',1p,e19.12,3x, &
4684 & '(Iter=',i3.3,')')
4685 40 FORMAT (2x,'Ortho Test: ', &
4686 & '<G(',i3.3,'),G(',i3.3,')> = ',1p,e15.8,1x, &
4687 & '<G(',i3.3,'),G(',i3.3,')> = ',1p,e15.8)
4688 END IF
4689# endif
4690!
4691 RETURN

References mod_iounits::adm, mod_iounits::calledfrom, mod_fourdvar::cg_beta, mod_fourdvar::cg_delta, mod_fourdvar::cg_gnorm, mod_fourdvar::cg_qg, mod_scalars::exit_flag, strings_mod::founderror(), mod_stepping::lnew, mod_stepping::lold, mod_parallel::master, mod_scalars::ndefadj, mod_scalars::noerror, mod_fourdvar::nstatevar, mod_iounits::sourcefile, state_addition_mod::state_addition(), state_dotprod_mod::state_dotprod(), state_read_mod::state_read(), state_scale_mod::state_scale(), and mod_iounits::stdout.

Referenced by cgradient_tile().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ new_cost()

subroutine, private cgradient_mod::new_cost ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) model,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
integer, intent(in) lbij,
integer, intent(in) ubij,
integer, intent(in) imins,
integer, intent(in) imaxs,
integer, intent(in) jmins,
integer, intent(in) jmaxs,
integer, intent(in) innloop,
integer, intent(in) outloop,
real(r8), dimension(lbi:,lbj:), intent(in) rmask,
real(r8), dimension(lbi:,lbj:), intent(in) umask,
real(r8), dimension(lbi:,lbj:), intent(in) vmask,
real(r8), dimension(lbij:,:,:,:,:,:), intent(inout) nl_t_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) nl_u_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) nl_v_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) nl_ubar_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) nl_vbar_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) nl_zeta_obc,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) nl_ustr,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) nl_vstr,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) nl_tflux,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) nl_t,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) nl_u,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) nl_v,
real(r8), dimension(lbi:,lbj:,:), intent(inout) nl_zeta )
private

Definition at line 5907 of file cgradient.F.

5933!***********************************************************************
5934!
5935! Imported variable declarations.
5936!
5937 integer, intent(in) :: ng, tile, model
5938 integer, intent(in) :: LBi, UBi, LBj, UBj, LBij, UBij
5939 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
5940 integer, intent(in) :: innLoop, outLoop
5941!
5942# ifdef ASSUMED_SHAPE
5943# ifdef MASKING
5944 real(r8), intent(in) :: rmask(LBi:,LBj:)
5945 real(r8), intent(in) :: umask(LBi:,LBj:)
5946 real(r8), intent(in) :: vmask(LBi:,LBj:)
5947# endif
5948# ifdef ADJUST_BOUNDARY
5949# ifdef SOLVE3D
5950 real(r8), intent(inout) :: nl_t_obc(LBij:,:,:,:,:,:)
5951 real(r8), intent(inout) :: nl_u_obc(LBij:,:,:,:,:)
5952 real(r8), intent(inout) :: nl_v_obc(LBij:,:,:,:,:)
5953# endif
5954 real(r8), intent(inout) :: nl_ubar_obc(LBij:,:,:,:)
5955 real(r8), intent(inout) :: nl_vbar_obc(LBij:,:,:,:)
5956 real(r8), intent(inout) :: nl_zeta_obc(LBij:,:,:,:)
5957# endif
5958# ifdef ADJUST_WSTRESS
5959 real(r8), intent(inout) :: nl_ustr(LBi:,LBj:,:,:)
5960 real(r8), intent(inout) :: nl_vstr(LBi:,LBj:,:,:)
5961# endif
5962# ifdef SOLVE3D
5963# ifdef ADJUST_STFLUX
5964 real(r8), intent(inout) :: nl_tflux(LBi:,LBj:,:,:,:)
5965# endif
5966 real(r8), intent(inout) :: nl_t(LBi:,LBj:,:,:,:)
5967 real(r8), intent(inout) :: nl_u(LBi:,LBj:,:,:)
5968 real(r8), intent(inout) :: nl_v(LBi:,LBj:,:,:)
5969# else
5970 real(r8), intent(inout) :: nl_ubar(LBi:,LBj:,:)
5971 real(r8), intent(inout) :: nl_vbar(LBi:,LBj:,:)
5972# endif
5973 real(r8), intent(inout) :: nl_zeta(LBi:,LBj:,:)
5974
5975# else
5976
5977# ifdef MASKING
5978 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
5979 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
5980 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
5981# endif
5982# ifdef ADJUST_BOUNDARY
5983# ifdef SOLVE3D
5984 real(r8), intent(inout) :: nl_t_obc(LBij:UBij,N(ng),4, &
5985 & Nbrec(ng),2,NT(ng))
5986 real(r8), intent(inout) :: nl_u_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
5987 real(r8), intent(inout) :: nl_v_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
5988# endif
5989 real(r8), intent(inout) :: nl_ubar_obc(LBij:UBij,4,Nbrec(ng),2)
5990 real(r8), intent(inout) :: nl_vbar_obc(LBij:UBij,4,Nbrec(ng),2)
5991 real(r8), intent(inout) :: nl_zeta_obc(LBij:UBij,4,Nbrec(ng),2)
5992# endif
5993# ifdef ADJUST_WSTRESS
5994 real(r8), intent(inout) :: nl_ustr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
5995 real(r8), intent(inout) :: nl_vstr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
5996# endif
5997# ifdef SOLVE3D
5998# ifdef ADJUST_STFLUX
5999 real(r8), intent(inout) :: nl_tflux(LBi:UBi,LBj:UBj, &
6000 & Nfrec(ng),2,NT(ng))
6001# endif
6002 real(r8), intent(inout) :: nl_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
6003 real(r8), intent(inout) :: nl_u(LBi:UBi,LBj:UBj,N(ng),2)
6004 real(r8), intent(inout) :: nl_v(LBi:UBi,LBj:UBj,N(ng),2)
6005# else
6006 real(r8), intent(inout) :: nl_ubar(LBi:UBi,LBj:UBj,:)
6007 real(r8), intent(inout) :: nl_vbar(LBi:UBi,LBj:UBj,:)
6008# endif
6009 real(r8), intent(inout) :: nl_zeta(LBi:UBi,LBj:UBj,:)
6010# endif
6011!
6012! Local variable declarations.
6013!
6014 logical :: Ltrans
6015!
6016 integer :: i, rec, Lscale
6017 integer :: L1 = 1
6018 integer :: L2 = 2
6019!
6020 real(r8) :: fac, fac1, fac2
6021
6022 real(r8), dimension(0:NstateVar(ng)) :: dot
6023!
6024 character (len=256) :: ncname
6025
6026 character (len=*), parameter :: MyFile = &
6027 & __FILE__//", new_cost"
6028
6029# include "set_bounds.h"
6030!
6031 calledfrom=myfile
6032 sourcefile=myfile
6033!
6034!-----------------------------------------------------------------------
6035! Compute the cost function based on the formula of Tshimanga
6036! (PhD thesis, p 154, eqn A.15):
6037!
6038! J = J_initial + 0.5 * transpose(r) Q z
6039!
6040! where J_initial is the value of the cost function when inner=0
6041! (i.e. Cost0), r is the initial cost function gradient when inner=0,
6042! Q is the matrix of Lanczos vectors, and z is the solution of
6043! Tz=-transpose(Q) r, T being the associated tridiagonal matrix of
6044! the Lanczos recursion. Note that even when r and x are in y-space,
6045! as in the preconditioned case, their dot-product is equal to that
6046! of the same variables transformed to v-space.
6047!-----------------------------------------------------------------------
6048!
6049! Compute the current increment and save in nl_var(L1).
6050!
6051! Clear the adjoint working arrays (index Linp) since the tangent
6052! linear model initial condition on the first inner-loop is zero:
6053!
6054! nl_var(L1) = fac
6055!
6056 fac=0.0_r8
6057
6058 CALL state_initialize (ng, tile, &
6059 & lbi, ubi, lbj, ubj, lbij, ubij, &
6060 & l1, fac, &
6061# ifdef MASKING
6062 & rmask, umask, vmask, &
6063# endif
6064# ifdef ADJUST_BOUNDARY
6065# ifdef SOLVE3D
6066 & nl_t_obc, nl_u_obc, nl_v_obc, &
6067# endif
6068 & nl_ubar_obc, nl_vbar_obc, &
6069 & nl_zeta_obc, &
6070# endif
6071# ifdef ADJUST_WSTRESS
6072 & nl_ustr, nl_vstr, &
6073# endif
6074# ifdef SOLVE3D
6075# ifdef ADJUST_STFLUX
6076 & nl_tflux, &
6077# endif
6078 & nl_t, nl_u, nl_v, &
6079# else
6080 & nl_ubar, nl_vbar, &
6081# endif
6082 & nl_zeta)
6083!
6084! Now compute nl_var(L1) = Q * cg_zu.
6085!
6086 IF (ndefadj(ng).gt.0) THEN
6087 WRITE (ncname,10) trim(adm(ng)%base), outloop
6088 10 FORMAT (a,'_',i3.3,'.nc')
6089 ELSE
6090 ncname=adm(ng)%name
6091 END IF
6092!
6093 DO rec=1,innloop
6094!
6095! Read gradient solution and load it into nl_var(L2).
6096!
6097 CALL state_read (ng, tile, model, adm(ng)%IOtype, &
6098 & lbi, ubi, lbj, ubj, lbij, ubij, &
6099 & l2, rec, &
6100 & ndefadj(ng), adm(ng)%ncid, &
6101# if defined PIO_LIB && defined DISTRIBUTE
6102 & adm(ng)%pioFile, &
6103# endif
6104 & ncname, &
6105# ifdef MASKING
6106 & rmask, umask, vmask, &
6107# endif
6108# ifdef ADJUST_BOUNDARY
6109# ifdef SOLVE3D
6110 & nl_t_obc, nl_u_obc, nl_v_obc, &
6111# endif
6112 & nl_ubar_obc, nl_vbar_obc, &
6113 & nl_zeta_obc, &
6114# endif
6115# ifdef ADJUST_WSTRESS
6116 & nl_ustr, nl_vstr, &
6117# endif
6118# ifdef SOLVE3D
6119# ifdef ADJUST_STFLUX
6120 & nl_tflux, &
6121# endif
6122 & nl_t, nl_u, nl_v, &
6123# else
6124 & nl_ubar, nl_vbar, &
6125# endif
6126 & nl_zeta)
6127 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
6128!
6129! Perform the summation:
6130!
6131! nl_var(L1) = fac1 * nl_var(L1) + fac2 * nl_var(L2)
6132!
6133 fac1=1.0_r8
6134 fac2=cg_zu(rec,outloop)
6135
6136 CALL state_addition (ng, tile, &
6137 & lbi, ubi, lbj, ubj, lbij, ubij, &
6138 & l1, l2, l1, fac1, fac2, &
6139# ifdef MASKING
6140 & rmask, umask, vmask, &
6141# endif
6142# ifdef ADJUST_BOUNDARY
6143# ifdef SOLVE3D
6144 & nl_t_obc, nl_t_obc, &
6145 & nl_u_obc, nl_u_obc, &
6146 & nl_v_obc, nl_v_obc, &
6147# endif
6148 & nl_ubar_obc, nl_ubar_obc, &
6149 & nl_vbar_obc, nl_vbar_obc, &
6150 & nl_zeta_obc, nl_zeta_obc, &
6151# endif
6152# ifdef ADJUST_WSTRESS
6153 & nl_ustr, nl_ustr, &
6154 & nl_vstr, nl_vstr, &
6155# endif
6156# ifdef SOLVE3D
6157# ifdef ADJUST_STFLUX
6158 & nl_tflux, nl_tflux, &
6159# endif
6160 & nl_t, nl_t, &
6161 & nl_u, nl_u, &
6162 & nl_v, nl_v, &
6163# else
6164 & nl_ubar, nl_ubar, &
6165 & nl_vbar, nl_vbar, &
6166# endif
6167 & nl_zeta, nl_zeta)
6168 END DO
6169!
6170! Now read the initial Lanczos vector again into nl_var(L2).
6171!
6172 rec=1
6173 IF (ndefadj(ng).gt.0) THEN
6174 WRITE (ncname,10) trim(adm(ng)%base), outloop
6175 ELSE
6176 ncname=adm(ng)%name
6177 END IF
6178!
6179 CALL state_read (ng, tile, model, adm(ng)%IOtype, &
6180 & lbi, ubi, lbj, ubj, lbij, ubij, &
6181 & l2, rec, &
6182 & ndefadj(ng), adm(ng)%ncid, &
6183# if defined PIO_LIB && defined DISTRIBUTE
6184 & adm(ng)%pioFile, &
6185# endif
6186 & ncname, &
6187# ifdef MASKING
6188 & rmask, umask, vmask, &
6189# endif
6190# ifdef ADJUST_BOUNDARY
6191# ifdef SOLVE3D
6192 & nl_t_obc, nl_u_obc, nl_v_obc, &
6193# endif
6194 & nl_ubar_obc, nl_vbar_obc, &
6195 & nl_zeta_obc, &
6196# endif
6197# ifdef ADJUST_WSTRESS
6198 & nl_ustr, nl_vstr, &
6199# endif
6200# ifdef SOLVE3D
6201# ifdef ADJUST_STFLUX
6202 & nl_tflux, &
6203# endif
6204 & nl_t, nl_u, nl_v, &
6205# else
6206 & nl_ubar, nl_vbar, &
6207# endif
6208 & nl_zeta)
6209 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
6210!
6211! Compute the dot-product of the initial Lanczos vector with the
6212! current increment.
6213!
6214 CALL state_dotprod (ng, tile, model, &
6215 & lbi, ubi, lbj, ubj, lbij, ubij, &
6216 & nstatevar(ng), dot(0:), &
6217# ifdef MASKING
6218 & rmask, umask, vmask, &
6219# endif
6220# ifdef ADJUST_BOUNDARY
6221# ifdef SOLVE3D
6222 & nl_t_obc(:,:,:,:,l1,:), &
6223 & nl_t_obc(:,:,:,:,l2,:), &
6224 & nl_u_obc(:,:,:,:,l1), &
6225 & nl_u_obc(:,:,:,:,l2), &
6226 & nl_v_obc(:,:,:,:,l1), &
6227 & nl_v_obc(:,:,:,:,l2), &
6228# endif
6229 & nl_ubar_obc(:,:,:,l1), &
6230 & nl_ubar_obc(:,:,:,l2), &
6231 & nl_vbar_obc(:,:,:,l1), &
6232 & nl_vbar_obc(:,:,:,l2), &
6233 & nl_zeta_obc(:,:,:,l1), &
6234 & nl_zeta_obc(:,:,:,l2), &
6235# endif
6236# ifdef ADJUST_WSTRESS
6237 & nl_ustr(:,:,:,l1), nl_ustr(:,:,:,l2), &
6238 & nl_vstr(:,:,:,l1), nl_vstr(:,:,:,l2), &
6239# endif
6240# ifdef SOLVE3D
6241# ifdef ADJUST_STFLUX
6242 & nl_tflux(:,:,:,l1,:), &
6243 & nl_tflux(:,:,:,l2,:), &
6244# endif
6245 & nl_t(:,:,:,l1,:), nl_t(:,:,:,l2,:), &
6246 & nl_u(:,:,:,l1), nl_u(:,:,:,l2), &
6247 & nl_v(:,:,:,l1), nl_v(:,:,:,l2), &
6248# else
6249 & nl_ubar(:,:,l1), nl_ubar(:,:,l2), &
6250 & nl_vbar(:,:,l1), nl_vbar(:,:,l2), &
6251# endif
6252 & nl_zeta(:,:,l1), nl_zeta(:,:,l2))
6253!
6254! Compute the new cost function. Only the total value is meaningful.
6255! Note that we need to multiply dot(0) by cg_Gnorm(outLoop) because
6256! the initial gradient is cg_Gnorm*q(0).
6257!
6258 fourdvar(ng)%CostFun(0)=fourdvar(ng)%Cost0(outloop)+ &
6259 & 0.5_r8*dot(0)*cg_gnorm(outloop)
6260 DO i=1,nobsvar(ng)
6261 fourdvar(ng)%CostFun(i)=0.0_r8
6262 END DO
6263!
6264! Compute the background cost function.
6265!
6266! If preconditioning, convert nl_var(L1) from y-space into v-space.
6267! This must be called before reading the sum of previous v-space
6268! gradient since nl_var(L2) is used a temporary storage in precond.
6269!
6270 IF (lprecond.and.(outloop.gt.1)) THEN
6271
6272 lscale=2 ! SQRT spectral LMP
6273 ltrans=.false.
6274!
6275 CALL precond (ng, tile, model, 'new cost function', &
6276 & lbi, ubi, lbj, ubj, lbij, ubij, &
6277 & imins, imaxs, jmins, jmaxs, &
6278 & nstatevar(ng), lscale, ltrans, &
6279 & innloop, outloop, &
6280# ifdef MASKING
6281 & rmask, umask, vmask, &
6282# endif
6283# ifdef ADJUST_BOUNDARY
6284# ifdef SOLVE3D
6285 & nl_t_obc, nl_u_obc, nl_v_obc, &
6286# endif
6287 & nl_ubar_obc, nl_vbar_obc, &
6288 & nl_zeta_obc, &
6289# endif
6290# ifdef ADJUST_WSTRESS
6291 & nl_ustr, nl_vstr, &
6292# endif
6293# ifdef SOLVE3D
6294# ifdef ADJUST_STFLUX
6295 & nl_tflux, &
6296# endif
6297 & nl_t, nl_u, nl_v, &
6298# else
6299 & nl_ubar, nl_vbar, &
6300# endif
6301 & nl_zeta)
6302 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
6303 END IF
6304!
6305! Read the sum of previous v-space gradients from record 4 of ITL
6306! tile into nl_var(L2). Note that all fields in the ITL file
6307! are in v-space so there is no need to apply the preconditioner
6308! to nl_var(L2).
6309!
6310 CALL state_read (ng, tile, model, itl(ng)%IOtype, &
6311 & lbi, ubi, lbj, ubj, lbij, ubij, &
6312 & l2, 4, &
6313 & ndeftlm(ng), itl(ng)%ncid, &
6314# if defined PIO_LIB && defined DISTRIBUTE
6315 & itl(ng)%pioFile, &
6316# endif
6317 & itl(ng)%name, &
6318# ifdef MASKING
6319 & rmask, umask, vmask, &
6320# endif
6321# ifdef ADJUST_BOUNDARY
6322# ifdef SOLVE3D
6323 & nl_t_obc, nl_u_obc, nl_v_obc, &
6324# endif
6325 & nl_ubar_obc, nl_vbar_obc, &
6326 & nl_zeta_obc, &
6327# endif
6328# ifdef ADJUST_WSTRESS
6329 & nl_ustr, nl_vstr, &
6330# endif
6331# ifdef SOLVE3D
6332# ifdef ADJUST_STFLUX
6333 & nl_tflux, &
6334# endif
6335 & nl_t, nl_u, nl_v, &
6336# else
6337 & nl_ubar, nl_vbar, &
6338# endif
6339 & nl_zeta)
6340 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
6341!
6342! Perform the summation:
6343!
6344! nl_var(L1) = fac1 * nl_var(L1) + fac2 * nl_var(L2)
6345!
6346 fac1=1.0_r8
6347 fac2=1.0_r8
6348
6349 CALL state_addition (ng, tile, &
6350 & lbi, ubi, lbj, ubj, lbij, ubij, &
6351 & l1, l2, l1, fac1, fac2, &
6352# ifdef MASKING
6353 & rmask, umask, vmask, &
6354# endif
6355# ifdef ADJUST_BOUNDARY
6356# ifdef SOLVE3D
6357 & nl_t_obc, nl_t_obc, &
6358 & nl_u_obc, nl_u_obc, &
6359 & nl_v_obc, nl_v_obc, &
6360# endif
6361 & nl_ubar_obc, nl_ubar_obc, &
6362 & nl_vbar_obc, nl_vbar_obc, &
6363 & nl_zeta_obc, nl_zeta_obc, &
6364# endif
6365# ifdef ADJUST_WSTRESS
6366 & nl_ustr, nl_ustr, &
6367 & nl_vstr, nl_vstr, &
6368# endif
6369# ifdef SOLVE3D
6370# ifdef ADJUST_STFLUX
6371 & nl_tflux, nl_tflux, &
6372# endif
6373 & nl_t, nl_t, &
6374 & nl_u, nl_u, &
6375 & nl_v, nl_v, &
6376# else
6377 & nl_ubar, nl_ubar, &
6378 & nl_vbar, nl_vbar, &
6379# endif
6380 & nl_zeta, nl_zeta)
6381!
6382 CALL state_dotprod (ng, tile, model, &
6383 & lbi, ubi, lbj, ubj, lbij, ubij, &
6384 & nstatevar(ng), dot(0:), &
6385# ifdef MASKING
6386 & rmask, umask, vmask, &
6387# endif
6388# ifdef ADJUST_BOUNDARY
6389# ifdef SOLVE3D
6390 & nl_t_obc(:,:,:,:,l1,:), &
6391 & nl_t_obc(:,:,:,:,l1,:), &
6392 & nl_u_obc(:,:,:,:,l1), &
6393 & nl_u_obc(:,:,:,:,l1), &
6394 & nl_v_obc(:,:,:,:,l1), &
6395 & nl_v_obc(:,:,:,:,l1), &
6396# endif
6397 & nl_ubar_obc(:,:,:,l1), &
6398 & nl_ubar_obc(:,:,:,l1), &
6399 & nl_vbar_obc(:,:,:,l1), &
6400 & nl_vbar_obc(:,:,:,l1), &
6401 & nl_zeta_obc(:,:,:,l1), &
6402 & nl_zeta_obc(:,:,:,l1), &
6403# endif
6404# ifdef ADJUST_WSTRESS
6405 & nl_ustr(:,:,:,l1), nl_ustr(:,:,:,l1), &
6406 & nl_vstr(:,:,:,l1), nl_vstr(:,:,:,l1), &
6407# endif
6408# ifdef SOLVE3D
6409# ifdef ADJUST_STFLUX
6410 & nl_tflux(:,:,:,l1,:), &
6411 & nl_tflux(:,:,:,l1,:), &
6412# endif
6413 & nl_t(:,:,:,l1,:), nl_t(:,:,:,l1,:), &
6414 & nl_u(:,:,:,l1), nl_u(:,:,:,l1), &
6415 & nl_v(:,:,:,l1), nl_v(:,:,:,l1), &
6416# else
6417 & nl_ubar(:,:,l1), nl_ubar(:,:,l1), &
6418 & nl_vbar(:,:,l1), nl_vbar(:,:,l1), &
6419# endif
6420 & nl_zeta(:,:,l1), nl_zeta(:,:,l1))
6421!
6422 fourdvar(ng)%BackCost(0)=0.5_r8*dot(0)
6423 fourdvar(ng)%ObsCost(0)=fourdvar(ng)%CostFun(0)- &
6424 & fourdvar(ng)%BackCost(0)
6425 DO i=1,nobsvar(ng)
6426 fourdvar(ng)%BackCost(i)=0.0_r8
6427 fourdvar(ng)%ObsCost(i)=0.0_r8
6428 END DO
6429
6430 RETURN

References mod_iounits::adm, mod_iounits::calledfrom, mod_fourdvar::cg_gnorm, mod_fourdvar::cg_zu, mod_scalars::exit_flag, strings_mod::founderror(), mod_fourdvar::fourdvar, mod_iounits::itl, mod_fourdvar::lprecond, mod_scalars::ndefadj, mod_scalars::ndeftlm, mod_fourdvar::nobsvar, mod_scalars::noerror, mod_fourdvar::nstatevar, precond(), mod_iounits::sourcefile, state_addition_mod::state_addition(), state_dotprod_mod::state_dotprod(), state_initialize_mod::state_initialize(), and state_read_mod::state_read().

Referenced by cgradient_tile().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ new_direction()

subroutine, private cgradient_mod::new_direction ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) model,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
integer, intent(in) lbij,
integer, intent(in) ubij,
integer, intent(in) imins,
integer, intent(in) imaxs,
integer, intent(in) jmins,
integer, intent(in) jmaxs,
integer, intent(in) lold,
integer, intent(in) lnew,
real(r8), dimension(lbi:,lbj:), intent(in) rmask,
real(r8), dimension(lbi:,lbj:), intent(in) umask,
real(r8), dimension(lbi:,lbj:), intent(in) vmask,
real(r8), dimension(lbij:,:,:,:,:,:), intent(in) ad_t_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(in) ad_u_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(in) ad_v_obc,
real(r8), dimension(lbij:,:,:,:), intent(in) ad_ubar_obc,
real(r8), dimension(lbij:,:,:,:), intent(in) ad_vbar_obc,
real(r8), dimension(lbij:,:,:,:), intent(in) ad_zeta_obc,
real(r8), dimension(lbi:,lbj:,:,:), intent(in) ad_ustr,
real(r8), dimension(lbi:,lbj:,:,:), intent(in) ad_vstr,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(in) ad_tflux,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(in) ad_t,
real(r8), dimension(lbi:,lbj:,:,:), intent(in) ad_u,
real(r8), dimension(lbi:,lbj:,:,:), intent(in) ad_v,
real(r8), dimension(lbi:,lbj:,:), intent(in) ad_zeta,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) d_t_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) d_u_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) d_v_obc,
real(r8), dimension(lbij:,:,:), intent(inout) d_ubar_obc,
real(r8), dimension(lbij:,:,:), intent(inout) d_vbar_obc,
real(r8), dimension(lbij:,:,:), intent(inout) d_zeta_obc,
real(r8), dimension(lbi:,lbj:,:), intent(inout) d_sustr,
real(r8), dimension(lbi:,lbj:,:), intent(inout) d_svstr,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) d_stflx,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) d_t,
real(r8), dimension(lbi:,lbj:,:), intent(inout) d_u,
real(r8), dimension(lbi:,lbj:,:), intent(inout) d_v,
real(r8), dimension(lbi:,lbj:), intent(inout) d_zeta )
private

Definition at line 2386 of file cgradient.F.

2431!***********************************************************************
2432!
2433! Imported variable declarations.
2434!
2435 integer, intent(in) :: ng, tile, model
2436 integer, intent(in) :: LBi, UBi, LBj, UBj, LBij, UBij
2437 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
2438 integer, intent(in) :: Lold, Lnew
2439!
2440# ifdef ASSUMED_SHAPE
2441# ifdef MASKING
2442 real(r8), intent(in) :: rmask(LBi:,LBj:)
2443 real(r8), intent(in) :: umask(LBi:,LBj:)
2444 real(r8), intent(in) :: vmask(LBi:,LBj:)
2445# endif
2446# ifdef ADJUST_BOUNDARY
2447# ifdef SOLVE3D
2448 real(r8), intent(in) :: ad_t_obc(LBij:,:,:,:,:,:)
2449 real(r8), intent(in) :: ad_u_obc(LBij:,:,:,:,:)
2450 real(r8), intent(in) :: ad_v_obc(LBij:,:,:,:,:)
2451# endif
2452 real(r8), intent(in) :: ad_ubar_obc(LBij:,:,:,:)
2453 real(r8), intent(in) :: ad_vbar_obc(LBij:,:,:,:)
2454 real(r8), intent(in) :: ad_zeta_obc(LBij:,:,:,:)
2455# endif
2456# ifdef ADJUST_WSTRESS
2457 real(r8), intent(in) :: ad_ustr(LBi:,LBj:,:,:)
2458 real(r8), intent(in) :: ad_vstr(LBi:,LBj:,:,:)
2459# endif
2460# ifdef SOLVE3D
2461# ifdef ADJUST_STFLUX
2462 real(r8), intent(in) :: ad_tflux(LBi:,LBj:,:,:,:)
2463# endif
2464 real(r8), intent(in) :: ad_t(LBi:,LBj:,:,:,:)
2465 real(r8), intent(in) :: ad_u(LBi:,LBj:,:,:)
2466 real(r8), intent(in) :: ad_v(LBi:,LBj:,:,:)
2467# else
2468 real(r8), intent(in) :: ad_ubar(LBi:,LBj:,:)
2469 real(r8), intent(in) :: ad_vbar(LBi:,LBj:,:)
2470# endif
2471 real(r8), intent(in) :: ad_zeta(LBi:,LBj:,:)
2472# ifdef ADJUST_BOUNDARY
2473# ifdef SOLVE3D
2474 real(r8), intent(inout) :: d_t_obc(LBij:,:,:,:,:)
2475 real(r8), intent(inout) :: d_u_obc(LBij:,:,:,:)
2476 real(r8), intent(inout) :: d_v_obc(LBij:,:,:,:)
2477# endif
2478 real(r8), intent(inout) :: d_ubar_obc(LBij:,:,:)
2479 real(r8), intent(inout) :: d_vbar_obc(LBij:,:,:)
2480 real(r8), intent(inout) :: d_zeta_obc(LBij:,:,:)
2481# endif
2482# ifdef ADJUST_WSTRESS
2483 real(r8), intent(inout) :: d_sustr(LBi:,LBj:,:)
2484 real(r8), intent(inout) :: d_svstr(LBi:,LBj:,:)
2485# endif
2486# ifdef SOLVE3D
2487# ifdef ADJUST_STFLUX
2488 real(r8), intent(inout) :: d_stflx(LBi:,LBj:,:,:)
2489# endif
2490 real(r8), intent(inout) :: d_t(LBi:,LBj:,:,:)
2491 real(r8), intent(inout) :: d_u(LBi:,LBj:,:)
2492 real(r8), intent(inout) :: d_v(LBi:,LBj:,:)
2493# else
2494 real(r8), intent(inout) :: d_ubar(LBi:,LBj:)
2495 real(r8), intent(inout) :: d_vbar(LBi:,LBj:)
2496# endif
2497 real(r8), intent(inout) :: d_zeta(LBi:,LBj:)
2498
2499# else
2500
2501# ifdef MASKING
2502 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
2503 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
2504 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
2505# endif
2506# ifdef ADJUST_BOUNDARY
2507# ifdef SOLVE3D
2508 real(r8), intent(in) :: ad_t_obc(LBij:UBij,N(ng),4, &
2509 & Nbrec(ng),2,NT(ng))
2510 real(r8), intent(in) :: ad_u_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
2511 real(r8), intent(in) :: ad_v_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
2512# endif
2513 real(r8), intent(in) :: ad_ubar_obc(LBij:UBij,4,Nbrec(ng),2)
2514 real(r8), intent(in) :: ad_vbar_obc(LBij:UBij,4,Nbrec(ng),2)
2515 real(r8), intent(in) :: ad_zeta_obc(LBij:UBij,4,Nbrec(ng),2)
2516# endif
2517# ifdef ADJUST_WSTRESS
2518 real(r8), intent(in) :: ad_ustr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
2519 real(r8), intent(in) :: ad_vstr(LBi:UBI,LBj:UBj,Nfrec(ng),2)
2520# endif
2521# ifdef SOLVE3D
2522# ifdef ADJUST_STFLUX
2523 real(r8), intent(in) :: ad_tflux(LBi:UBi,LBj:UBj, &
2524 & Nfrec(ng),2,NT(ng))
2525# endif
2526 real(r8), intent(in) :: ad_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
2527 real(r8), intent(in) :: ad_u(LBi:UBi,LBj:UBj,N(ng),2)
2528 real(r8), intent(in) :: ad_v(LBi:UBi,LBj:UBj,N(ng),2)
2529# else
2530 real(r8), intent(in) :: ad_ubar(LBi:UBi,LBj:UBj,:)
2531 real(r8), intent(in) :: ad_vbar(LBi:UBi,LBj:UBj,:)
2532# endif
2533 real(r8), intent(in) :: ad_zeta(LBi:UBi,LBj:UBj,:)
2534# ifdef ADJUST_BOUNDARY
2535# ifdef SOLVE3D
2536 real(r8), intent(inout) :: d_t_obc(LBij:UBij,N(ng),4, &
2537 & Nbrec(ng),NT(ng))
2538 real(r8), intent(inout) :: d_u_obc(LBij:UBij,N(ng),4,Nbrec(ng))
2539 real(r8), intent(inout) :: d_v_obc(LBij:UBij,N(ng),4,Nbrec(ng))
2540# endif
2541 real(r8), intent(inout) :: d_ubar_obc(LBij:UBij,4,Nbrec(ng))
2542 real(r8), intent(inout) :: d_vbar_obc(LBij:UBij,4,Nbrec(ng))
2543 real(r8), intent(inout) :: d_zeta_obc(LBij:UBij,4,Nbrec(ng))
2544# endif
2545# ifdef ADJUST_WSTRESS
2546 real(r8), intent(inout) :: d_sustr(LBi:UBi,LBj:UBj,Nfrec(ng))
2547 real(r8), intent(inout) :: d_svstr(LBi:UBI,LBj:UBj,Nfrec(ng))
2548# endif
2549# ifdef SOLVE3D
2550# ifdef ADJUST_STFLUX
2551 real(r8), intent(inout) :: d_stflx(LBi:UBi,LBj:UBj, &
2552 & Nfrec(ng),NT(ng))
2553# endif
2554 real(r8), intent(inout) :: d_t(LBi:UBi,LBj:UBj,N(ng),NT(ng))
2555 real(r8), intent(inout) :: d_u(LBi:UBi,LBj:UBj,N(ng))
2556 real(r8), intent(inout) :: d_v(LBi:UBi,LBj:UBj,N(ng))
2557# else
2558 real(r8), intent(inout) :: d_ubar(LBi:UBi,LBj:UBj)
2559 real(r8), intent(inout) :: d_vbar(LBi:UBi,LBj:UBj)
2560# endif
2561 real(r8), intent(inout) :: d_zeta(LBi:UBi,LBj:UBj)
2562# endif
2563!
2564! Local variable declarations.
2565!
2566 integer :: i, j, k
2567 integer :: ib, ir, it
2568
2569# include "set_bounds.h"
2570!
2571!-----------------------------------------------------------------------
2572! Compute new conjugate descent direction, d(k+1). Notice that the old
2573! descent direction is overwritten.
2574!-----------------------------------------------------------------------
2575!
2576! Free-sruface.
2577!
2578 DO j=jstrr,jendr
2579 DO i=istrr,iendr
2580 d_zeta(i,j)=ad_zeta(i,j,lnew)
2581# ifdef MASKING
2582 d_zeta(i,j)=d_zeta(i,j)*rmask(i,j)
2583# endif
2584 END DO
2585 END DO
2586
2587# ifdef ADJUST_BOUNDARY
2588!
2589! Free-surface open boundaries.
2590!
2591 IF (any(lobc(:,isfsur,ng))) THEN
2592 DO ir=1,nbrec(ng)
2593 IF ((lobc(iwest,isfsur,ng)).and. &
2594 & domain(ng)%Western_Edge(tile)) THEN
2595 ib=iwest
2596 DO j=jstr,jend
2597 d_zeta_obc(j,ib,ir)=ad_zeta_obc(j,ib,ir,lnew)
2598# ifdef MASKING
2599 d_zeta_obc(j,ib,ir)=d_zeta_obc(j,ib,ir)* &
2600 & rmask(istr-1,j)
2601# endif
2602 END DO
2603 END IF
2604 IF ((lobc(ieast,isfsur,ng)).and. &
2605 & domain(ng)%Eastern_Edge(tile)) THEN
2606 ib=ieast
2607 DO j=jstr,jend
2608 d_zeta_obc(j,ib,ir)=ad_zeta_obc(j,ib,ir,lnew)
2609# ifdef MASKING
2610 d_zeta_obc(j,ib,ir)=d_zeta_obc(j,ib,ir)* &
2611 & rmask(iend+1,j)
2612# endif
2613 END DO
2614 END IF
2615 IF ((lobc(isouth,isfsur,ng)).and. &
2616 & domain(ng)%Southern_Edge(tile)) THEN
2617 ib=isouth
2618 DO i=istr,iend
2619 d_zeta_obc(i,ib,ir)=ad_zeta_obc(i,ib,ir,lnew)
2620# ifdef MASKING
2621 d_zeta_obc(i,ib,ir)=d_zeta_obc(i,ib,ir)* &
2622 & rmask(i,jstr-1)
2623# endif
2624 END DO
2625 END IF
2626 IF ((lobc(inorth,isfsur,ng)).and. &
2627 & domain(ng)%Northern_Edge(tile)) THEN
2628 ib=inorth
2629 DO i=istr,iend
2630 d_zeta_obc(i,ib,ir)=ad_zeta_obc(i,ib,ir,lnew)
2631# ifdef MASKING
2632 d_zeta_obc(i,ib,ir)=d_zeta_obc(i,ib,ir)* &
2633 & rmask(i,jend+1)
2634# endif
2635 END DO
2636 END IF
2637 END DO
2638 END IF
2639# endif
2640
2641# ifndef SOLVE3D
2642!
2643! 2D U-momentum.
2644!
2645 DO j=jstrr,jendr
2646 DO i=istr,iendr
2647 d_ubar(i,j)=ad_ubar(i,j,lnew)
2648# ifdef MASKING
2649 d_ubar(i,j)=d_ubar(i,j)*umask(i,j)
2650# endif
2651 END DO
2652 END DO
2653# endif
2654
2655# ifdef ADJUST_BOUNDARY
2656!
2657! 2D U-momentum open boundaries.
2658!
2659 IF (any(lobc(:,isubar,ng))) THEN
2660 DO ir=1,nbrec(ng)
2661 IF ((lobc(iwest,isubar,ng)).and. &
2662 & domain(ng)%Western_Edge(tile)) THEN
2663 ib=iwest
2664 DO j=jstr,jend
2665 d_ubar_obc(j,ib,ir)=ad_ubar_obc(j,ib,ir,lnew)
2666# ifdef MASKING
2667 d_ubar_obc(j,ib,ir)=d_ubar_obc(j,ib,ir)* &
2668 & umask(istr,j)
2669# endif
2670 END DO
2671 END IF
2672 IF ((lobc(ieast,isubar,ng)).and. &
2673 & domain(ng)%Eastern_Edge(tile)) THEN
2674 ib=ieast
2675 DO j=jstr,jend
2676 d_ubar_obc(j,ib,ir)=ad_ubar_obc(j,ib,ir,lnew)
2677# ifdef MASKING
2678 d_ubar_obc(j,ib,ir)=d_ubar_obc(j,ib,ir)* &
2679 & umask(iend+1,j)
2680# endif
2681 END DO
2682 END IF
2683 IF ((lobc(isouth,isubar,ng)).and. &
2684 & domain(ng)%Southern_Edge(tile)) THEN
2685 ib=isouth
2686 DO i=istru,iend
2687 d_ubar_obc(i,ib,ir)=ad_ubar_obc(i,ib,ir,lnew)
2688# ifdef MASKING
2689 d_ubar_obc(i,ib,ir)=d_ubar_obc(i,ib,ir)* &
2690 & umask(i,jstr-1)
2691# endif
2692 END DO
2693 END IF
2694 IF ((lobc(inorth,isubar,ng)).and. &
2695 & domain(ng)%Northern_Edge(tile)) THEN
2696 ib=inorth
2697 DO i=istru,iend
2698 d_ubar_obc(i,ib,ir)=ad_ubar_obc(i,ib,ir,lnew)
2699# ifdef MASKING
2700 d_ubar_obc(i,ib,ir)=d_ubar_obc(i,ib,ir)* &
2701 & umask(i,jend+1)
2702# endif
2703 END DO
2704 END IF
2705 END DO
2706 END IF
2707# endif
2708
2709# ifndef SOLVE3D
2710!
2711! 2D V-momentum.
2712!
2713 DO j=jstr,jendr
2714 DO i=istrr,iendr
2715 d_vbar(i,j)=ad_vbar(i,j,lnew)
2716# ifdef MASKING
2717 d_vbar(i,j)=d_vbar(i,j)*vmask(i,j)
2718# endif
2719 END DO
2720 END DO
2721# endif
2722
2723# ifdef ADJUST_BOUNDARY
2724!
2725! 2D V-momentum open boundaries.
2726!
2727 IF (any(lobc(:,isvbar,ng))) THEN
2728 DO ir=1,nbrec(ng)
2729 IF ((lobc(iwest,isvbar,ng)).and. &
2730 & domain(ng)%Western_Edge(tile)) THEN
2731 ib=iwest
2732 DO j=jstrv,jend
2733 d_vbar_obc(j,ib,ir)=ad_vbar_obc(j,ib,ir,lnew)
2734# ifdef MASKING
2735 d_vbar_obc(j,ib,ir)=d_vbar_obc(j,ib,ir)* &
2736 & vmask(istr-1,j)
2737# endif
2738 END DO
2739 END IF
2740 IF ((lobc(ieast,isvbar,ng)).and. &
2741 & domain(ng)%Eastern_Edge(tile)) THEN
2742 ib=ieast
2743 DO j=jstrv,jend
2744 d_vbar_obc(j,ib,ir)=ad_vbar_obc(j,ib,ir,lnew)
2745# ifdef MASKING
2746 d_vbar_obc(j,ib,ir)=d_vbar_obc(j,ib,ir)* &
2747 & vmask(iend+1,j)
2748# endif
2749 END DO
2750 END IF
2751 IF ((lobc(isouth,isvbar,ng)).and. &
2752 & domain(ng)%Southern_Edge(tile)) THEN
2753 ib=isouth
2754 DO i=istr,iend
2755 d_vbar_obc(i,ib,ir)=ad_vbar_obc(i,ib,ir,lnew)
2756# ifdef MASKING
2757 d_vbar_obc(i,ib,ir)=d_vbar_obc(i,ib,ir)* &
2758 & vmask(i,jstr)
2759# endif
2760 END DO
2761 END IF
2762 IF ((lobc(inorth,isvbar,ng)).and. &
2763 & domain(ng)%Northern_Edge(tile)) THEN
2764 ib=inorth
2765 DO i=istr,iend
2766 d_vbar_obc(i,ib,ir)=ad_vbar_obc(i,ib,ir,lnew)
2767# ifdef MASKING
2768 d_vbar_obc(i,ib,ir)=d_vbar_obc(i,ib,ir)* &
2769 & vmask(i,jend+1)
2770# endif
2771 END DO
2772 END IF
2773 END DO
2774 END IF
2775# endif
2776
2777# ifdef ADJUST_WSTRESS
2778!
2779! Surface momentum stress.
2780!
2781 DO ir=1,nfrec(ng)
2782 DO j=jstrr,jendr
2783 DO i=istr,iendr
2784 d_sustr(i,j,ir)=ad_ustr(i,j,ir,lnew)
2785# ifdef MASKING
2786 d_sustr(i,j,ir)=d_sustr(i,j,ir)*umask(i,j)
2787# endif
2788 END DO
2789 END DO
2790 DO j=jstr,jendr
2791 DO i=istrr,iendr
2792 d_svstr(i,j,ir)=ad_vstr(i,j,ir,lnew)
2793# ifdef MASKING
2794 d_svstr(i,j,ir)=d_svstr(i,j,ir)*vmask(i,j)
2795# endif
2796 END DO
2797 END DO
2798 END DO
2799# endif
2800
2801# ifdef SOLVE3D
2802!
2803! 3D U-momentum.
2804!
2805 DO k=1,n(ng)
2806 DO j=jstrr,jendr
2807 DO i=istr,iendr
2808 d_u(i,j,k)=ad_u(i,j,k,lnew)
2809# ifdef MASKING
2810 d_u(i,j,k)=d_u(i,j,k)*umask(i,j)
2811# endif
2812 END DO
2813 END DO
2814 END DO
2815
2816# ifdef ADJUST_BOUNDARY
2817!
2818! 3D U-momentum open boundaries.
2819!
2820 IF (any(lobc(:,isuvel,ng))) THEN
2821 DO ir=1,nbrec(ng)
2822 IF ((lobc(iwest,isuvel,ng)).and. &
2823 & domain(ng)%Western_Edge(tile)) THEN
2824 ib=iwest
2825 DO k=1,n(ng)
2826 DO j=jstr,jend
2827 d_u_obc(j,k,ib,ir)=ad_u_obc(j,k,ib,ir,lnew)
2828# ifdef MASKING
2829 d_u_obc(j,k,ib,ir)=d_u_obc(j,k,ib,ir)* &
2830 & umask(istr,j)
2831# endif
2832 END DO
2833 END DO
2834 END IF
2835 IF ((lobc(ieast,isuvel,ng)).and. &
2836 & domain(ng)%Eastern_Edge(tile)) THEN
2837 ib=ieast
2838 DO k=1,n(ng)
2839 DO j=jstr,jend
2840 d_u_obc(j,k,ib,ir)=ad_u_obc(j,k,ib,ir,lnew)
2841# ifdef MASKING
2842 d_u_obc(j,k,ib,ir)=d_u_obc(j,k,ib,ir)* &
2843 & umask(iend+1,j)
2844# endif
2845 END DO
2846 END DO
2847 END IF
2848 IF ((lobc(isouth,isuvel,ng)).and. &
2849 & domain(ng)%Southern_Edge(tile)) THEN
2850 ib=isouth
2851 DO k=1,n(ng)
2852 DO i=istru,iend
2853 d_u_obc(i,k,ib,ir)=ad_u_obc(i,k,ib,ir,lnew)
2854# ifdef MASKING
2855 d_u_obc(i,k,ib,ir)=d_u_obc(i,k,ib,ir)* &
2856 & umask(i,jstr-1)
2857# endif
2858 END DO
2859 END DO
2860 END IF
2861 IF ((lobc(inorth,isuvel,ng)).and. &
2862 & domain(ng)%Northern_Edge(tile)) THEN
2863 ib=inorth
2864 DO k=1,n(ng)
2865 DO i=istru,iend
2866 d_u_obc(i,k,ib,ir)=ad_u_obc(i,k,ib,ir,lnew)
2867# ifdef MASKING
2868 d_u_obc(i,k,ib,ir)=d_u_obc(i,k,ib,ir)* &
2869 & umask(i,jend+1)
2870# endif
2871 END DO
2872 END DO
2873 END IF
2874 END DO
2875 END IF
2876# endif
2877!
2878! 3D V-momentum.
2879!
2880 DO k=1,n(ng)
2881 DO j=jstr,jendr
2882 DO i=istrr,iendr
2883 d_v(i,j,k)=ad_v(i,j,k,lnew)
2884# ifdef MASKING
2885 d_v(i,j,k)=d_v(i,j,k)*vmask(i,j)
2886# endif
2887 END DO
2888 END DO
2889 END DO
2890
2891# ifdef ADJUST_BOUNDARY
2892!
2893! 3D V-momentum open boundaries.
2894!
2895 IF (any(lobc(:,isvvel,ng))) THEN
2896 DO ir=1,nbrec(ng)
2897 IF ((lobc(iwest,isvvel,ng)).and. &
2898 & domain(ng)%Western_Edge(tile)) THEN
2899 ib=iwest
2900 DO k=1,n(ng)
2901 DO j=jstrv,jend
2902 d_v_obc(j,k,ib,ir)=ad_v_obc(j,k,ib,ir,lnew)
2903# ifdef MASKING
2904 d_v_obc(j,k,ib,ir)=d_v_obc(j,k,ib,ir)* &
2905 & vmask(istr-1,j)
2906# endif
2907 END DO
2908 END DO
2909 END IF
2910 IF ((lobc(ieast,isvvel,ng)).and. &
2911 & domain(ng)%Eastern_Edge(tile)) THEN
2912 ib=ieast
2913 DO k=1,n(ng)
2914 DO j=jstrv,jend
2915 d_v_obc(j,k,ib,ir)=ad_v_obc(j,k,ib,ir,lnew)
2916# ifdef MASKING
2917 d_v_obc(j,k,ib,ir)=d_v_obc(j,k,ib,ir)* &
2918 & vmask(iend+1,j)
2919# endif
2920 END DO
2921 END DO
2922 END IF
2923 IF ((lobc(isouth,isvvel,ng)).and. &
2924 & domain(ng)%Southern_Edge(tile)) THEN
2925 ib=isouth
2926 DO k=1,n(ng)
2927 DO i=istr,iend
2928 d_v_obc(i,k,ib,ir)=ad_v_obc(i,k,ib,ir,lnew)
2929# ifdef MASKING
2930 d_v_obc(i,k,ib,ir)=d_v_obc(i,k,ib,ir)* &
2931 & vmask(i,jstr)
2932# endif
2933 END DO
2934 END DO
2935 END IF
2936 IF ((lobc(inorth,isvvel,ng)).and. &
2937 & domain(ng)%Northern_Edge(tile)) THEN
2938 ib=inorth
2939 DO k=1,n(ng)
2940 DO i=istr,iend
2941 d_v_obc(i,k,ib,ir)=ad_v_obc(i,k,ib,ir,lnew)
2942# ifdef MASKING
2943 d_v_obc(i,k,ib,ir)=d_v_obc(i,k,ib,ir)* &
2944 & vmask(i,jend+1)
2945# endif
2946 END DO
2947 END DO
2948 END IF
2949 END DO
2950 END IF
2951# endif
2952!
2953! Tracers.
2954!
2955 DO it=1,nt(ng)
2956 DO k=1,n(ng)
2957 DO j=jstrr,jendr
2958 DO i=istrr,iendr
2959 d_t(i,j,k,it)=ad_t(i,j,k,lnew,it)
2960# ifdef MASKING
2961 d_t(i,j,k,it)=d_t(i,j,k,it)*rmask(i,j)
2962# endif
2963 END DO
2964 END DO
2965 END DO
2966 END DO
2967
2968# ifdef ADJUST_BOUNDARY
2969!
2970! Tracers open boundaries.
2971!
2972 DO it=1,nt(ng)
2973 IF (any(lobc(:,istvar(it),ng))) THEN
2974 DO ir=1,nbrec(ng)
2975 IF ((lobc(iwest,istvar(it),ng)).and. &
2976 & domain(ng)%Western_Edge(tile)) THEN
2977 ib=iwest
2978 DO k=1,n(ng)
2979 DO j=jstr,jend
2980 d_t_obc(j,k,ib,ir,it)=ad_t_obc(j,k,ib,ir,lnew,it)
2981# ifdef MASKING
2982 d_t_obc(j,k,ib,ir,it)=d_t_obc(j,k,ib,ir,it)* &
2983 & rmask(istr-1,j)
2984# endif
2985 END DO
2986 END DO
2987 END IF
2988 IF ((lobc(ieast,istvar(it),ng)).and. &
2989 & domain(ng)%Eastern_Edge(tile)) THEN
2990 ib=ieast
2991 DO k=1,n(ng)
2992 DO j=jstr,jend
2993 d_t_obc(j,k,ib,ir,it)=ad_t_obc(j,k,ib,ir,lnew,it)
2994# ifdef MASKING
2995 d_t_obc(j,k,ib,ir,it)=d_t_obc(j,k,ib,ir,it)* &
2996 & rmask(iend+1,j)
2997# endif
2998 END DO
2999 END DO
3000 END IF
3001 IF ((lobc(isouth,istvar(it),ng)).and. &
3002 & domain(ng)%Southern_Edge(tile)) THEN
3003 ib=isouth
3004 DO k=1,n(ng)
3005 DO i=istr,iend
3006 d_t_obc(i,k,ib,ir,it)=ad_t_obc(i,k,ib,ir,lnew,it)
3007# ifdef MASKING
3008 d_t_obc(i,k,ib,ir,it)=d_t_obc(i,k,ib,ir,it)* &
3009 & rmask(i,jstr-1)
3010# endif
3011 END DO
3012 END DO
3013 END IF
3014 IF ((lobc(inorth,istvar(it),ng)).and. &
3015 & domain(ng)%Northern_Edge(tile)) THEN
3016 ib=inorth
3017 DO k=1,n(ng)
3018 DO i=istr,iend
3019 d_t_obc(i,k,ib,ir,it)=ad_t_obc(i,k,ib,ir,lnew,it)
3020# ifdef MASKING
3021 d_t_obc(i,k,ib,ir,it)=d_t_obc(i,k,ib,ir,it)* &
3022 & rmask(i,jend+1)
3023# endif
3024 END DO
3025 END DO
3026 END IF
3027 END DO
3028 END IF
3029 END DO
3030# endif
3031
3032# ifdef ADJUST_STFLUX
3033!
3034! Surface tracers flux.
3035!
3036 DO it=1,nt(ng)
3037 IF (lstflux(it,ng)) THEN
3038 DO ir=1,nfrec(ng)
3039 DO j=jstrr,jendr
3040 DO i=istrr,iendr
3041 d_stflx(i,j,ir,it)=ad_tflux(i,j,ir,lnew,it)
3042# ifdef MASKING
3043 d_stflx(i,j,ir,it)=d_stflx(i,j,ir,it)*rmask(i,j)
3044# endif
3045 END DO
3046 END DO
3047 END DO
3048 END IF
3049 END DO
3050# endif
3051# endif
3052!
3053 RETURN

References mod_param::domain, mod_scalars::ieast, mod_scalars::inorth, mod_ncparam::isfsur, mod_scalars::isouth, mod_ncparam::istvar, mod_ncparam::isubar, mod_ncparam::isuvel, mod_ncparam::isvbar, mod_ncparam::isvvel, mod_scalars::iwest, mod_stepping::lnew, mod_scalars::lobc, mod_scalars::lstflux, mod_param::n, mod_scalars::nbrec, mod_scalars::nfrec, and mod_param::nt.

Referenced by cgradient_tile().

Here is the caller graph for this function:

◆ new_gradient()

subroutine, private cgradient_mod::new_gradient ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) model,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
integer, intent(in) lbij,
integer, intent(in) ubij,
integer, intent(in) imins,
integer, intent(in) imaxs,
integer, intent(in) jmins,
integer, intent(in) jmaxs,
integer, intent(in) lold,
integer, intent(in) lnew,
integer, intent(in) lwrk,
integer, intent(in) innloop,
integer, intent(in) outloop,
real(r8), dimension(lbi:,lbj:), intent(in) rmask,
real(r8), dimension(lbi:,lbj:), intent(in) umask,
real(r8), dimension(lbi:,lbj:), intent(in) vmask,
real(r8), dimension(lbij:,:,:,:,:,:), intent(inout) tl_t_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) tl_u_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) tl_v_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) tl_ubar_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) tl_vbar_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) tl_zeta_obc,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) tl_ustr,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) tl_vstr,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) tl_tflux,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) tl_t,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) tl_u,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) tl_v,
real(r8), dimension(lbi:,lbj:,:), intent(inout) tl_zeta,
real(r8), dimension(lbij:,:,:,:,:,:), intent(inout) ad_t_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) ad_u_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) ad_v_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) ad_ubar_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) ad_vbar_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) ad_zeta_obc,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) ad_ustr,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) ad_vstr,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) ad_tflux,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) ad_t,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) ad_u,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) ad_v,
real(r8), dimension(lbi:,lbj:,:), intent(inout) ad_zeta )
private

Definition at line 4695 of file cgradient.F.

4741!
4742!***********************************************************************
4743!
4744! Imported variable declarations.
4745!
4746 integer, intent(in) :: ng, tile, model
4747 integer, intent(in) :: LBi, UBi, LBj, UBj, LBij, UBij
4748 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
4749 integer, intent(in) :: Lold, Lnew, Lwrk
4750 integer, intent(in) :: innLoop, outLoop
4751!
4752# ifdef ASSUMED_SHAPE
4753# ifdef MASKING
4754 real(r8), intent(in) :: rmask(LBi:,LBj:)
4755 real(r8), intent(in) :: umask(LBi:,LBj:)
4756 real(r8), intent(in) :: vmask(LBi:,LBj:)
4757# endif
4758# ifdef ADJUST_WSTRESS
4759 real(r8), intent(inout) :: ad_ustr(LBi:,LBj:,:,:)
4760 real(r8), intent(inout) :: ad_vstr(LBi:,LBj:,:,:)
4761# endif
4762# ifdef SOLVE3D
4763# ifdef ADJUST_BOUNDARY
4764# ifdef SOLVE3D
4765 real(r8), intent(inout) :: ad_t_obc(LBij:,:,:,:,:,:)
4766 real(r8), intent(inout) :: ad_u_obc(LBij:,:,:,:,:)
4767 real(r8), intent(inout) :: ad_v_obc(LBij:,:,:,:,:)
4768# endif
4769 real(r8), intent(inout) :: ad_ubar_obc(LBij:,:,:,:)
4770 real(r8), intent(inout) :: ad_vbar_obc(LBij:,:,:,:)
4771 real(r8), intent(inout) :: ad_zeta_obc(LBij:,:,:,:)
4772# endif
4773# ifdef ADJUST_STFLUX
4774 real(r8), intent(inout) :: ad_tflux(LBi:,LBj:,:,:,:)
4775# endif
4776 real(r8), intent(inout) :: ad_t(LBi:,LBj:,:,:,:)
4777 real(r8), intent(inout) :: ad_u(LBi:,LBj:,:,:)
4778 real(r8), intent(inout) :: ad_v(LBi:,LBj:,:,:)
4779# else
4780 real(r8), intent(inout) :: ad_ubar(LBi:,LBj:,:)
4781 real(r8), intent(inout) :: ad_vbar(LBi:,LBj:,:)
4782# endif
4783 real(r8), intent(inout) :: ad_zeta(LBi:,LBj:,:)
4784# ifdef ADJUST_BOUNDARY
4785# ifdef SOLVE3D
4786 real(r8), intent(inout) :: tl_t_obc(LBij:,:,:,:,:,:)
4787 real(r8), intent(inout) :: tl_u_obc(LBij:,:,:,:,:)
4788 real(r8), intent(inout) :: tl_v_obc(LBij:,:,:,:,:)
4789# endif
4790 real(r8), intent(inout) :: tl_ubar_obc(LBij:,:,:,:)
4791 real(r8), intent(inout) :: tl_vbar_obc(LBij:,:,:,:)
4792 real(r8), intent(inout) :: tl_zeta_obc(LBij:,:,:,:)
4793# endif
4794# ifdef ADJUST_WSTRESS
4795 real(r8), intent(inout) :: tl_ustr(LBi:,LBj:,:,:)
4796 real(r8), intent(inout) :: tl_vstr(LBi:,LBj:,:,:)
4797# endif
4798# ifdef SOLVE3D
4799# ifdef ADJUST_STFLUX
4800 real(r8), intent(inout) :: tl_tflux(LBi:,LBj:,:,:,:)
4801# endif
4802 real(r8), intent(inout) :: tl_t(LBi:,LBj:,:,:,:)
4803 real(r8), intent(inout) :: tl_u(LBi:,LBj:,:,:)
4804 real(r8), intent(inout) :: tl_v(LBi:,LBj:,:,:)
4805# else
4806 real(r8), intent(inout) :: tl_ubar(LBi:,LBj:,:)
4807 real(r8), intent(inout) :: tl_vbar(LBi:,LBj:,:)
4808# endif
4809 real(r8), intent(inout) :: tl_zeta(LBi:,LBj:,:)
4810
4811# else
4812
4813# ifdef MASKING
4814 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
4815 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
4816 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
4817# endif
4818# ifdef ADJUST_BOUNDARY
4819# ifdef SOLVE3D
4820 real(r8), intent(inout) :: ad_t_obc(LBij:UBij,N(ng),4, &
4821 & Nbrec(ng),2,NT(ng))
4822 real(r8), intent(inout) :: ad_u_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
4823 real(r8), intent(inout) :: ad_v_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
4824# endif
4825 real(r8), intent(inout) :: ad_ubar_obc(LBij:UBij,4,Nbrec(ng),2)
4826 real(r8), intent(inout) :: ad_vbar_obc(LBij:UBij,4,Nbrec(ng),2)
4827 real(r8), intent(inout) :: ad_zeta_obc(LBij:UBij,4,Nbrec(ng),2)
4828# endif
4829# ifdef ADJUST_WSTRESS
4830 real(r8), intent(inout) :: ad_ustr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
4831 real(r8), intent(inout) :: ad_vstr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
4832# endif
4833# ifdef SOLVE3D
4834# ifdef ADJUST_STFLUX
4835 real(r8), intent(inout) :: ad_tflux(LBi:UBi,LBj:UBj, &
4836 & Nfrec(ng),2,NT(ng))
4837# endif
4838 real(r8), intent(inout) :: ad_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
4839 real(r8), intent(inout) :: ad_u(LBi:UBi,LBj:UBj,N(ng),2)
4840 real(r8), intent(inout) :: ad_v(LBi:UBi,LBj:UBj,N(ng),2)
4841# else
4842 real(r8), intent(inout) :: ad_ubar(LBi:UBi,LBj:UBj,:)
4843 real(r8), intent(inout) :: ad_vbar(LBi:UBi,LBj:UBj,:)
4844# endif
4845 real(r8), intent(inout) :: ad_zeta(LBi:UBi,LBj:UBj,:)
4846# ifdef ADJUST_BOUNDARY
4847# ifdef SOLVE3D
4848 real(r8), intent(inout) :: tl_t_obc(LBij:UBij,N(ng),4, &
4849 & Nbrec(ng),2,NT(ng))
4850 real(r8), intent(inout) :: tl_u_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
4851 real(r8), intent(inout) :: tl_v_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
4852# endif
4853 real(r8), intent(inout) :: tl_ubar_obc(LBij:UBij,4,Nbrec(ng),2)
4854 real(r8), intent(inout) :: tl_vbar_obc(LBij:UBij,4,Nbrec(ng),2)
4855 real(r8), intent(inout) :: tl_zeta_obc(LBij:UBij,4,Nbrec(ng),2)
4856# endif
4857# ifdef ADJUST_WSTRESS
4858 real(r8), intent(inout) :: tl_ustr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
4859 real(r8), intent(inout) :: tl_vstr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
4860# endif
4861# ifdef SOLVE3D
4862# ifdef ADJUST_STFLUX
4863 real(r8), intent(inout) :: tl_tflux(LBi:UBi,LBj:UBj, &
4864 & Nfrec(ng),2,NT(ng))
4865# endif
4866 real(r8), intent(inout) :: tl_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
4867 real(r8), intent(inout) :: tl_u(LBi:UBi,LBj:UBj,N(ng),2)
4868 real(r8), intent(inout) :: tl_v(LBi:UBi,LBj:UBj,N(ng),2)
4869# else
4870 real(r8), intent(inout) :: tl_ubar(LBi:UBi,LBj:UBj,:)
4871 real(r8), intent(inout) :: tl_vbar(LBi:UBi,LBj:UBj,:)
4872# endif
4873 real(r8), intent(inout) :: tl_zeta(LBi:UBi,LBj:UBj,:)
4874# endif
4875!
4876! Local variable declarations.
4877!
4878 integer :: rec
4879!
4880 real(r8) :: fac1, fac2
4881
4882 real(r8), dimension(0:NstateVar(ng)) :: dot
4883 real(r8), dimension(0:Ninner) :: DotProd, dot_new, dot_old
4884!
4885 character (len=256) :: ncname
4886
4887 character (len=*), parameter :: MyFile = &
4888 & __FILE__//", new_gradient"
4889
4890# include "set_bounds.h"
4891!
4892 calledfrom=myfile
4893 sourcefile=myfile
4894!
4895!-----------------------------------------------------------------------
4896! Computes the gradient of the cost function at the new point.
4897!-----------------------------------------------------------------------
4898!
4899! Need to multiply the gradient (index Lold) by cg_Gnorm because it has
4900! been normalized:
4901!
4902! ad_var(Lold) = fac1 * ad_var(Lold) + fac2 * ad_var(Lnew)
4903!
4904 fac1=cg_gnorm(outloop)
4905 fac2=cg_beta(innloop+1,outloop)*cg_tmatrix(innloop,3)
4906
4907 CALL state_addition (ng, tile, &
4908 & lbi, ubi, lbj, ubj, lbij, ubij, &
4909 & lold, lnew, lold, fac1, fac2, &
4910# ifdef MASKING
4911 & rmask, umask, vmask, &
4912# endif
4913# ifdef ADJUST_BOUNDARY
4914# ifdef SOLVE3D
4915 & ad_t_obc, ad_t_obc, &
4916 & ad_u_obc, ad_u_obc, &
4917 & ad_v_obc, ad_v_obc, &
4918# endif
4919 & ad_ubar_obc, ad_ubar_obc, &
4920 & ad_vbar_obc, ad_vbar_obc, &
4921 & ad_zeta_obc, ad_zeta_obc, &
4922# endif
4923# ifdef ADJUST_WSTRESS
4924 & ad_ustr, ad_ustr, &
4925 & ad_vstr, ad_vstr, &
4926# endif
4927# ifdef SOLVE3D
4928# ifdef ADJUST_STFLUX
4929 & ad_tflux, ad_tflux, &
4930# endif
4931 & ad_t, ad_t, &
4932 & ad_u, ad_u, &
4933 & ad_v, ad_v, &
4934# else
4935 & ad_ubar, ad_ubar, &
4936 & ad_vbar, ad_vbar, &
4937# endif
4938 & ad_zeta, ad_zeta)
4939!
4940! Adjust gradient against all previous gradients.
4941!
4942 IF (ndefadj(ng).gt.0) THEN
4943 WRITE (ncname,10) trim(adm(ng)%base), outloop
4944 10 FORMAT (a,'_',i3.3,'.nc')
4945 ELSE
4946 ncname=adm(ng)%name
4947 END IF
4948!
4949 DO rec=1,innloop
4950!
4951! Read in each previous gradient state solutions, G(0) to G(k), and
4952! compute its associated dot angaint curret G(k+1). Each gradient
4953! solution is loaded into TANGENT LINEAR STATE ARRAYS at index Lwrk.
4954!
4955 CALL state_read (ng, tile, model, adm(ng)%IOtype, &
4956 & lbi, ubi, lbj, ubj, lbij, ubij, &
4957 & lwrk, rec, &
4958 & ndefadj(ng), adm(ng)%ncid, &
4959# if defined PIO_LIB && defined DISTRIBUTE
4960 & adm(ng)%pioFile, &
4961# endif
4962 & ncname, &
4963# ifdef MASKING
4964 & rmask, umask, vmask, &
4965# endif
4966# ifdef ADJUST_BOUNDARY
4967# ifdef SOLVE3D
4968 & tl_t_obc, tl_u_obc, tl_v_obc, &
4969# endif
4970 & tl_ubar_obc, tl_vbar_obc, &
4971 & tl_zeta_obc, &
4972# endif
4973# ifdef ADJUST_WSTRESS
4974 & tl_ustr, tl_vstr, &
4975# endif
4976# ifdef SOLVE3D
4977# ifdef ADJUST_STFLUX
4978 & tl_tflux, &
4979# endif
4980 & tl_t, tl_u, tl_v, &
4981# else
4982 & tl_ubar, tl_vbar, &
4983# endif
4984 & tl_zeta)
4985 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4986!
4987! In this expression for FAC2, the term cg_QG gives the contribution
4988! to the gradient of Jo, and the term cg_Tmatrix gives the contribution
4989! of Jb:
4990!
4991! ad_var(Lold) = fac1 * ad_var(Lold) + fac2 * tl_var(Lwrk)
4992!
4993! AMM: I do not think the second term in fac2 is needed now since we
4994! are always working in terms of the total gradient of J=Jb+Jo.
4995! CHECK:
4996!
4997! fac2=-(cg_Tmatrix(rec,3)+cg_QG(rec,outLoop))
4998!
4999 fac1=1.0_r8
5000 fac2=-cg_qg(rec,outloop)
5001
5002 CALL state_addition (ng, tile, &
5003 & lbi, ubi, lbj, ubj, lbij, ubij, &
5004 & lold, lwrk, lold, fac1, fac2, &
5005# ifdef MASKING
5006 & rmask, umask, vmask, &
5007# endif
5008# ifdef ADJUST_BOUNDARY
5009# ifdef SOLVE3D
5010 & ad_t_obc, tl_t_obc, &
5011 & ad_u_obc, tl_u_obc, &
5012 & ad_v_obc, tl_v_obc, &
5013# endif
5014 & ad_ubar_obc, tl_ubar_obc, &
5015 & ad_vbar_obc, tl_vbar_obc, &
5016 & ad_zeta_obc, tl_zeta_obc, &
5017# endif
5018# ifdef ADJUST_WSTRESS
5019 & ad_ustr, tl_ustr, &
5020 & ad_vstr, tl_vstr, &
5021# endif
5022# ifdef SOLVE3D
5023# ifdef ADJUST_STFLUX
5024 & ad_tflux, tl_tflux, &
5025# endif
5026 & ad_t, tl_t, &
5027 & ad_u, tl_u, &
5028 & ad_v, tl_v, &
5029# else
5030 & ad_ubar, tl_ubar, &
5031 & ad_vbar, tl_vbar, &
5032# endif
5033 & ad_zeta, tl_zeta)
5034 END DO
5035!
5036! Compute cost function gradient reduction.
5037!
5038 CALL state_dotprod (ng, tile, model, &
5039 & lbi, ubi, lbj, ubj, lbij, ubij, &
5040 & nstatevar(ng), dot(0:), &
5041# ifdef MASKING
5042 & rmask, umask, vmask, &
5043# endif
5044# ifdef ADJUST_BOUNDARY
5045# ifdef SOLVE3D
5046 & ad_t_obc(:,:,:,:,lold,:), &
5047 & ad_t_obc(:,:,:,:,lold,:), &
5048 & ad_u_obc(:,:,:,:,lold), &
5049 & ad_u_obc(:,:,:,:,lold), &
5050 & ad_v_obc(:,:,:,:,lold), &
5051 & ad_v_obc(:,:,:,:,lold), &
5052# endif
5053 & ad_ubar_obc(:,:,:,lold), &
5054 & ad_ubar_obc(:,:,:,lold), &
5055 & ad_vbar_obc(:,:,:,lold), &
5056 & ad_vbar_obc(:,:,:,lold), &
5057 & ad_zeta_obc(:,:,:,lold), &
5058 & ad_zeta_obc(:,:,:,lold), &
5059# endif
5060# ifdef ADJUST_WSTRESS
5061 & ad_ustr(:,:,:,lold), ad_ustr(:,:,:,lold), &
5062 & ad_vstr(:,:,:,lold), ad_vstr(:,:,:,lold), &
5063# endif
5064# ifdef SOLVE3D
5065# ifdef ADJUST_STFLUX
5066 & ad_tflux(:,:,:,lold,:), &
5067 & ad_tflux(:,:,:,lold,:), &
5068# endif
5069 & ad_t(:,:,:,lold,:), ad_t(:,:,:,lold,:), &
5070 & ad_u(:,:,:,lold), ad_u(:,:,:,lold), &
5071 & ad_v(:,:,:,lold), ad_v(:,:,:,lold), &
5072# else
5073 & ad_ubar(:,:,lold), ad_ubar(:,:,lold), &
5074 & ad_vbar(:,:,lold), ad_vbar(:,:,lold), &
5075# endif
5076 & ad_zeta(:,:,lold), ad_zeta(:,:,lold))
5077
5078 cg_greduc(innloop,outloop)=sqrt(dot(0))/cg_gnorm(outloop)
5079!
5080 RETURN

References mod_iounits::adm, mod_iounits::calledfrom, mod_fourdvar::cg_beta, mod_fourdvar::cg_gnorm, mod_fourdvar::cg_greduc, mod_fourdvar::cg_qg, mod_fourdvar::cg_tmatrix, mod_scalars::exit_flag, strings_mod::founderror(), mod_stepping::lnew, mod_stepping::lold, mod_scalars::ndefadj, mod_scalars::noerror, mod_fourdvar::nstatevar, mod_iounits::sourcefile, state_addition_mod::state_addition(), state_dotprod_mod::state_dotprod(), and state_read_mod::state_read().

Referenced by cgradient_tile().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ precond()

subroutine, private cgradient_mod::precond ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) model,
character (len=*), intent(in) message,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
integer, intent(in) lbij,
integer, intent(in) ubij,
integer, intent(in) imins,
integer, intent(in) imaxs,
integer, intent(in) jmins,
integer, intent(in) jmaxs,
integer, intent(in) nstatevars,
integer, intent(in) lscale,
logical, intent(in) ltrans,
integer, intent(in) innloop,
integer, intent(in) outloop,
real(r8), dimension(lbi:,lbj:), intent(in) rmask,
real(r8), dimension(lbi:,lbj:), intent(in) umask,
real(r8), dimension(lbi:,lbj:), intent(in) vmask,
real(r8), dimension(lbij:,:,:,:,:,:), intent(inout) nl_t_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) nl_u_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) nl_v_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) nl_ubar_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) nl_vbar_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) nl_zeta_obc,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) nl_ustr,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) nl_vstr,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) nl_tflux,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) nl_t,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) nl_u,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) nl_v,
real(r8), dimension(lbi:,lbj:,:), intent(inout) nl_zeta )
private

Definition at line 6434 of file cgradient.F.

6461!***********************************************************************
6462!
6463! Imported variable declarations.
6464!
6465 logical, intent(in) :: Ltrans
6466
6467 integer, intent(in) :: ng, tile, model
6468 integer, intent(in) :: LBi, UBi, LBj, UBj, LBij, UBij
6469 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
6470 integer, intent(in) :: NstateVars, Lscale
6471 integer, intent(in) :: innLoop, outLoop
6472
6473 character (len=*), intent(in) :: message
6474!
6475# ifdef ASSUMED_SHAPE
6476# ifdef MASKING
6477 real(r8), intent(in) :: rmask(LBi:,LBj:)
6478 real(r8), intent(in) :: umask(LBi:,LBj:)
6479 real(r8), intent(in) :: vmask(LBi:,LBj:)
6480# endif
6481# ifdef ADJUST_BOUNDARY
6482# ifdef SOLVE3D
6483 real(r8), intent(inout) :: nl_t_obc(LBij:,:,:,:,:,:)
6484 real(r8), intent(inout) :: nl_u_obc(LBij:,:,:,:,:)
6485 real(r8), intent(inout) :: nl_v_obc(LBij:,:,:,:,:)
6486# endif
6487 real(r8), intent(inout) :: nl_ubar_obc(LBij:,:,:,:)
6488 real(r8), intent(inout) :: nl_vbar_obc(LBij:,:,:,:)
6489 real(r8), intent(inout) :: nl_zeta_obc(LBij:,:,:,:)
6490# endif
6491# ifdef ADJUST_WSTRESS
6492 real(r8), intent(inout) :: nl_ustr(LBi:,LBj:,:,:)
6493 real(r8), intent(inout) :: nl_vstr(LBi:,LBj:,:,:)
6494# endif
6495# ifdef SOLVE3D
6496# ifdef ADJUST_STFLUX
6497 real(r8), intent(inout) :: nl_tflux(LBi:,LBj:,:,:,:)
6498# endif
6499 real(r8), intent(inout) :: nl_t(LBi:,LBj:,:,:,:)
6500 real(r8), intent(inout) :: nl_u(LBi:,LBj:,:,:)
6501 real(r8), intent(inout) :: nl_v(LBi:,LBj:,:,:)
6502# else
6503 real(r8), intent(inout) :: nl_ubar(LBi:,LBj:,:)
6504 real(r8), intent(inout) :: nl_vbar(LBi:,LBj:,:)
6505# endif
6506 real(r8), intent(inout) :: nl_zeta(LBi:,LBj:,:)
6507
6508# else
6509
6510# ifdef MASKING
6511 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
6512 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
6513 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
6514# endif
6515# ifdef ADJUST_BOUNDARY
6516# ifdef SOLVE3D
6517 real(r8), intent(inout) :: nl_t_obc(LBij:UBij,N(ng),4, &
6518 & Nbrec(ng),2,NT(ng))
6519 real(r8), intent(inout) :: nl_u_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
6520 real(r8), intent(inout) :: nl_v_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
6521# endif
6522 real(r8), intent(inout) :: nl_ubar_obc(LBij:UBij,4,Nbrec(ng),2)
6523 real(r8), intent(inout) :: nl_vbar_obc(LBij:UBij,4,Nbrec(ng),2)
6524 real(r8), intent(inout) :: nl_zeta_obc(LBij:UBij,4,Nbrec(ng),2)
6525# endif
6526# ifdef ADJUST_WSTRESS
6527 real(r8), intent(inout) :: nl_ustr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
6528 real(r8), intent(inout) :: nl_vstr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
6529# endif
6530# ifdef SOLVE3D
6531# ifdef ADJUST_STFLUX
6532 real(r8), intent(inout) :: nl_tflux(LBi:UBi,LBj:UBj, &
6533 & Nfrec(ng),2,NT(ng))
6534# endif
6535 real(r8), intent(inout) :: nl_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
6536 real(r8), intent(inout) :: nl_u(LBi:UBi,LBj:UBj,N(ng),2)
6537 real(r8), intent(inout) :: nl_v(LBi:UBi,LBj:UBj,N(ng),2)
6538# else
6539 real(r8), intent(inout) :: nl_ubar(LBi:UBi,LBj:UBj,:)
6540 real(r8), intent(inout) :: nl_vbar(LBi:UBi,LBj:UBj,:)
6541# endif
6542 real(r8), intent(inout) :: nl_zeta(LBi:UBi,LBj:UBj,:)
6543# endif
6544!
6545! Local variable declarations.
6546!
6547 integer :: NSUB, i, j, k, L1, L2, nvec, rec, ndefLCZ
6548 integer :: is, ie, inc, iss, ncid
6549 integer :: nol, nols, nole, ninc
6550 integer :: ingood
6551 integer :: namm
6552# ifdef SOLVE3D
6553 integer :: it
6554# endif
6555 integer, parameter :: ndef = 1
6556!
6557 real(r8) :: cff, fac, fac1, fac2, facritz
6558 real(r8), dimension(0:NstateVars) :: Dotprod
6559 real(r8), dimension(1:Ninner+1,Nouter) :: beta_lcz
6560 real(r8), dimension(Ninner,Ninner) :: zv_lcz
6561!
6562 character (len=256) :: ncname
6563
6564# ifdef DISTRIBUTE
6565 character (len=3) :: op_handle
6566# endif
6567
6568 character (len=*), parameter :: MyFile = &
6569 & __FILE__//", precond"
6570
6571# include "set_bounds.h"
6572!
6573 calledfrom=myfile
6574 sourcefile=myfile
6575!
6576!-----------------------------------------------------------------------
6577! THIS PRECONDITIONER IS WRITTEN IN PRODUCT FORM AS DESCRIBED BY
6578! TSHIMANGA - PhD thesis, page 75, proof of proposition 2.3.1.
6579! IT IS THEREFORE IMPORTANT THAT THE EIGENVECTORS/RITZ VECTORS THAT
6580! ARE COMPUTED BY is4dvar_lanczos.h ARE ORTHONORMALIZED.
6581!
6582! Apply the preconditioner. The approximated Hessian matrix is computed
6583! from the eigenvectors computed by the Lanczos algorithm which are
6584! stored in HSS(ng)%name NetCDF file.
6585!-----------------------------------------------------------------------
6586!
6587 l1=1
6588 l2=2
6589!
6590! Set the do-loop indices for the sequential preconditioner
6591! loop.
6592!
6593 IF (ltrans) THEN
6594 nols=outloop-1
6595 nole=1
6596 ninc=-1
6597 ELSE
6598 nols=1
6599 nole=outloop-1
6600 ninc=1
6601 END IF
6602
6603 IF (master) THEN
6604 IF (lritz) THEN
6605 WRITE (stdout,10) outloop, innloop, 'Ritz', trim(message)
6606 ELSE
6607 WRITE (stdout,10) outloop, innloop, 'Spectral', trim(message)
6608 END IF
6609 END IF
6610!
6611! Apply the preconditioners derived from all previous outer-loops
6612! sequentially.
6613!
6614 DO nol=nols,nole,ninc
6615!
6616! Read the primitive Ritz vectors cg_v and cg_beta.
6617!
6618 WRITE (ncname,20) trim(adm(ng)%base), nol
6619 IF (master) THEN
6620 WRITE (stdout,30) outloop, innloop, trim(ncname)
6621 END IF
6622!
6623 SELECT CASE (hss(ng)%IOtype)
6624 CASE (io_nf90)
6625 CALL netcdf_get_fvar (ng, model, ncname, &
6626 & 'cg_beta', beta_lcz)
6627 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
6628
6629 CALL netcdf_get_fvar (ng, model, ncname, &
6630 & 'cg_zv', zv_lcz)
6631 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
6632
6633# if defined PIO_LIB && defined DISTRIBUTE
6634 CASE (io_pio)
6635 CALL pio_netcdf_get_fvar (ng, model, ncname, &
6636 & 'cg_beta', beta_lcz)
6637 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
6638
6639 CALL pio_netcdf_get_fvar (ng, model, ncname, &
6640 & 'cg_zv', zv_lcz)
6641 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
6642# endif
6643 END SELECT
6644!
6645! Determine the number of Ritz vectors to use.
6646! For Lritz=.TRUE., choose HvecErr to be larger.
6647!
6648 ingood=0
6649 DO i=1,ninner
6650 IF (cg_ritzerr(i,nol).le.ritzmaxerr) THEN
6651 ingood=ingood+1
6652 END IF
6653 END DO
6654 IF (nritzev.gt.0) THEN
6655 nconvritz=nritzev
6656 ingood=nconvritz
6657 ELSE
6658 nconvritz=ingood
6659 END IF
6660 IF (master) THEN
6661 WRITE (stdout,40) outloop, innloop, ingood
6662 END IF
6663!
6664 IF (lscale.gt.0) THEN
6665 is=1
6666 ie=ingood
6667 inc=1
6668 ELSE
6669 is=ingood
6670 ie=1
6671 inc=-1
6672 END IF
6673!
6674 IF (ltrans) THEN
6675 iss=is
6676 is=ie
6677 ie=iss
6678 inc=-inc
6679 END IF
6680!
6681 DO nvec=is,ie,inc
6682!
6683 fac2=0.0_r8
6684!
6685! If using the Ritz preconditioner, read information from the
6686! Lanczos vector file.
6687!
6688 IF (lritz) THEN
6689!
6690 IF (.not.ltrans)THEN
6691!
6692! Determine adjoint file to process.
6693!
6694 WRITE (ncname,20) trim(adm(ng)%base), nol
6695 IF (master.and.(nvec.eq.is)) THEN
6696 WRITE (stdout,50) outloop, innloop, trim(ncname)
6697 END IF
6698!
6699! Read in the Lanczos vector q_k+1 computed from the incremental
6700! 4DVar algorithm previous outers loop, where k=Ninner+1. Load
6701! Lanczos vectors into NL state arrays at index L2.
6702!
6703 rec=ninner+1
6704 CALL state_read (ng, tile, model, adm(ng)%IOtype, &
6705 & lbi, ubi, lbj, ubj, lbij, ubij, &
6706 & l2, rec, &
6707 & ndef, ncid, &
6708# if defined PIO_LIB && defined DISTRIBUTE
6709 & adm(ng)%pioFile, &
6710# endif
6711 & ncname, &
6712# ifdef MASKING
6713 & rmask, umask, vmask, &
6714# endif
6715# ifdef ADJUST_BOUNDARY
6716# ifdef SOLVE3D
6717 & nl_t_obc, nl_u_obc, nl_v_obc, &
6718# endif
6719 & nl_ubar_obc, nl_vbar_obc, &
6720 & nl_zeta_obc, &
6721# endif
6722# ifdef ADJUST_WSTRESS
6723 & nl_ustr, nl_vstr, &
6724# endif
6725# ifdef SOLVE3D
6726# ifdef ADJUST_STFLUX
6727 & nl_tflux, &
6728# endif
6729 & nl_t, nl_u, nl_v, &
6730# else
6731 & nl_ubar, nl_vbar, &
6732# endif
6733 & nl_zeta)
6734 IF (founderror(exit_flag, noerror, &
6735 & __line__, myfile)) RETURN
6736!
6737! Compute the dot-product between the input vector and the Ninner+1
6738! Lanczos vector.
6739!
6740 CALL state_dotprod (ng, tile, model, &
6741 & lbi, ubi, lbj, ubj, lbij, ubij, &
6742 & nstatevars, dotprod(0:), &
6743# ifdef MASKING
6744 & rmask, umask, vmask, &
6745# endif
6746# ifdef ADJUST_BOUNDARY
6747# ifdef SOLVE3D
6748 & nl_t_obc(:,:,:,:,l1,:), &
6749 & nl_t_obc(:,:,:,:,l2,:), &
6750 & nl_u_obc(:,:,:,:,l1), &
6751 & nl_u_obc(:,:,:,:,l2), &
6752 & nl_v_obc(:,:,:,:,l1), &
6753 & nl_v_obc(:,:,:,:,l2), &
6754# endif
6755 & nl_ubar_obc(:,:,:,l1), &
6756 & nl_ubar_obc(:,:,:,l2), &
6757 & nl_vbar_obc(:,:,:,l1), &
6758 & nl_vbar_obc(:,:,:,l2), &
6759 & nl_zeta_obc(:,:,:,l1), &
6760 & nl_zeta_obc(:,:,:,l2), &
6761# endif
6762# ifdef ADJUST_WSTRESS
6763 & nl_ustr(:,:,:,l1), nl_ustr(:,:,:,l2), &
6764 & nl_vstr(:,:,:,l1), nl_vstr(:,:,:,l2), &
6765# endif
6766# ifdef SOLVE3D
6767# ifdef ADJUST_STFLUX
6768 & nl_tflux(:,:,:,l1,:), &
6769 & nl_tflux(:,:,:,l2,:), &
6770# endif
6771 & nl_t(:,:,:,l1,:), nl_t(:,:,:,l2,:), &
6772 & nl_u(:,:,:,l1), nl_u(:,:,:,l2), &
6773 & nl_v(:,:,:,l1), nl_v(:,:,:,l2), &
6774# else
6775 & nl_ubar(:,:,l1), nl_ubar(:,:,l2), &
6776 & nl_vbar(:,:,l1), nl_vbar(:,:,l2), &
6777# endif
6778 & nl_zeta(:,:,l1), nl_zeta(:,:,l2))
6779
6780 END IF
6781!
6782! Note: the primitive Ritz vectors zv_lcz are arranged in order of
6783! ASCENDING eigenvalue while the Hessian eigenvectors are
6784! arranged in DESCENDING order.
6785!
6786 facritz=beta_lcz(ninner+1,nol)*zv_lcz(ninner,ninner+1-nvec)
6787
6788 IF (.not.ltrans) THEN
6789 facritz=facritz*dotprod(0)
6790 END IF
6791
6792 END IF
6793!
6794! Read the converged Hessian eigenvectors into NLM state array,
6795! index L2.
6796!
6797 WRITE (ncname,20) trim(hss(ng)%base), nol
6798 IF (master.and.(nvec.eq.is)) THEN
6799 WRITE (stdout,60) outloop, innloop, trim(ncname)
6800 END IF
6801!
6802 CALL state_read (ng, tile, model, hss(ng)%IOtype, &
6803 & lbi, ubi, lbj, ubj, lbij, ubij, &
6804 & l2, nvec, &
6805 & ndef, ncid, &
6806# if defined PIO_LIB && defined DISTRIBUTE
6807 & hss(ng)%pioFile, &
6808# endif
6809 & ncname, &
6810# ifdef MASKING
6811 & rmask, umask, vmask, &
6812# endif
6813# ifdef ADJUST_BOUNDARY
6814# ifdef SOLVE3D
6815 & nl_t_obc, nl_u_obc, nl_v_obc, &
6816# endif
6817 & nl_ubar_obc, nl_vbar_obc, &
6818 & nl_zeta_obc, &
6819# endif
6820# ifdef ADJUST_WSTRESS
6821 & nl_ustr, nl_vstr, &
6822# endif
6823# ifdef SOLVE3D
6824# ifdef ADJUST_STFLUX
6825 & nl_tflux, &
6826# endif
6827 & nl_t, nl_u, nl_v, &
6828# else
6829 & nl_ubar, nl_vbar, &
6830# endif
6831 & nl_zeta)
6832 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
6833!
6834! Compute dot product between input vector and Hessian eigenvector.
6835! The input vector is in nl_var(L1) and the Hessian vector in
6836! nl_var(L2)
6837!
6838 CALL state_dotprod (ng, tile, model, &
6839 & lbi, ubi, lbj, ubj, lbij, ubij, &
6840 & nstatevars, dotprod(0:), &
6841# ifdef MASKING
6842 & rmask, umask, vmask, &
6843# endif
6844# ifdef ADJUST_BOUNDARY
6845# ifdef SOLVE3D
6846 & nl_t_obc(:,:,:,:,l1,:), &
6847 & nl_t_obc(:,:,:,:,l2,:), &
6848 & nl_u_obc(:,:,:,:,l1), &
6849 & nl_u_obc(:,:,:,:,l2), &
6850 & nl_v_obc(:,:,:,:,l1), &
6851 & nl_v_obc(:,:,:,:,l2), &
6852# endif
6853 & nl_ubar_obc(:,:,:,l1), &
6854 & nl_ubar_obc(:,:,:,l2), &
6855 & nl_vbar_obc(:,:,:,l1), &
6856 & nl_vbar_obc(:,:,:,l2), &
6857 & nl_zeta_obc(:,:,:,l1), &
6858 & nl_zeta_obc(:,:,:,l2), &
6859# endif
6860# ifdef ADJUST_WSTRESS
6861 & nl_ustr(:,:,:,l1), nl_ustr(:,:,:,l2), &
6862 & nl_vstr(:,:,:,l1), nl_vstr(:,:,:,l2), &
6863# endif
6864# ifdef SOLVE3D
6865# ifdef ADJUST_STFLUX
6866 & nl_tflux(:,:,:,l1,:), &
6867 & nl_tflux(:,:,:,l2,:), &
6868# endif
6869 & nl_t(:,:,:,l1,:), nl_t(:,:,:,l2,:), &
6870 & nl_u(:,:,:,l1), nl_u(:,:,:,l2), &
6871 & nl_v(:,:,:,l1), nl_v(:,:,:,l2), &
6872# else
6873 & nl_ubar(:,:,l1), nl_ubar(:,:,l2), &
6874 & nl_vbar(:,:,l1), nl_vbar(:,:,l2), &
6875# endif
6876 & nl_zeta(:,:,l1), nl_zeta(:,:,l2))
6877!
6878! Lscale determines the form of the preconditioner:
6879!
6880! 1= spectral LMP
6881! -1= Inverse spectral LMP
6882! 2= Square root spectral LMP
6883! -2= Inverse square spectral root LMP
6884!
6885! nl_var(L1) = fac1 * nl_var(L1) + fac2 * nl_var(L2)
6886!
6887! Note: cg_Ritz contains the Ritz values written in ASCENDING order.
6888!
6889 fac1=1.0_r8
6890
6891 IF (lscale.eq.-1) THEN
6892 fac2=(cg_ritz(ninner+1-nvec,nol)-1.0_r8)*dotprod(0)
6893 ELSE IF (lscale.eq.1) THEN
6894 fac2=(1.0_r8/cg_ritz(ninner+1-nvec,nol)-1.0_r8)*dotprod(0)
6895 ELSE IF (lscale.eq.-2) THEN
6896 fac2=(sqrt(cg_ritz(ninner+1-nvec,nol))-1.0_r8)*dotprod(0)
6897 ELSE IF (lscale.eq.2) THEN
6898 fac2=(1.0_r8/sqrt(cg_ritz(ninner+1-nvec,nol))-1.0_r8)* &
6899 & dotprod(0)
6900 END IF
6901!
6902 IF (.not.ltrans) THEN
6903 IF (lritz.and.(lscale.eq.-2)) THEN
6904 fac2=fac2+facritz/sqrt(cg_ritz(ninner+1-nvec,nol))
6905 END IF
6906 IF (lritz.and.(lscale.eq.2)) THEN
6907 fac2=fac2-facritz/cg_ritz(ninner+1-nvec,nol)
6908 END IF
6909 END IF
6910!
6911 CALL state_addition (ng, tile, &
6912 & lbi, ubi, lbj, ubj, lbij, ubij, &
6913 & l1, l2, l1, fac1, fac2, &
6914# ifdef MASKING
6915 & rmask, umask, vmask, &
6916# endif
6917# ifdef ADJUST_BOUNDARY
6918# ifdef SOLVE3D
6919 & nl_t_obc, nl_t_obc, &
6920 & nl_u_obc, nl_u_obc, &
6921 & nl_v_obc, nl_v_obc, &
6922# endif
6923 & nl_ubar_obc, nl_ubar_obc, &
6924 & nl_vbar_obc, nl_vbar_obc, &
6925 & nl_zeta_obc, nl_zeta_obc, &
6926# endif
6927# ifdef ADJUST_WSTRESS
6928 & nl_ustr, nl_ustr, &
6929 & nl_vstr, nl_vstr, &
6930# endif
6931# ifdef SOLVE3D
6932# ifdef ADJUST_STFLUX
6933 & nl_tflux, nl_tflux, &
6934# endif
6935 & nl_t, nl_t, &
6936 & nl_u, nl_u, &
6937 & nl_v, nl_v, &
6938# else
6939 & nl_ubar, nl_ubar, &
6940 & nl_vbar, nl_vbar, &
6941# endif
6942 & nl_zeta, nl_zeta)
6943!
6944 IF (lritz.and.ltrans) THEN
6945
6946 WRITE (ncname,20) trim(adm(ng)%base), nol
6947 IF (master.and.(nvec.eq.is)) THEN
6948 WRITE (stdout,50) outloop, innloop, trim(ncname)
6949 END IF
6950!
6951! Read in the Lanczos vector q_k+1 computed from the incremental
6952! 4DVar algorithm first outer loop, where k=Ninner+1. Load Lanczos
6953! vectors into NL state arrays at index L2.
6954!
6955 rec=ninner+1
6956 CALL state_read (ng, tile, model, adm(ng)%IOtype, &
6957 & lbi, ubi, lbj, ubj, lbij, ubij, &
6958 & l2, rec, &
6959 & ndef, ncid, &
6960# if defined PIO_LIB && defined DISTRIBUTE
6961 & adm(ng)%pioFile, &
6962# endif
6963 & ncname, &
6964# ifdef MASKING
6965 & rmask, umask, vmask, &
6966# endif
6967# ifdef ADJUST_BOUNDARY
6968# ifdef SOLVE3D
6969 & nl_t_obc, nl_u_obc, nl_v_obc, &
6970# endif
6971 & nl_ubar_obc, nl_vbar_obc, &
6972 & nl_zeta_obc, &
6973# endif
6974# ifdef ADJUST_WSTRESS
6975 & nl_ustr, nl_vstr, &
6976# endif
6977# ifdef SOLVE3D
6978# ifdef ADJUST_STFLUX
6979 & nl_tflux, &
6980# endif
6981 & nl_t, nl_u, nl_v, &
6982# else
6983 & nl_ubar, nl_vbar, &
6984# endif
6985 & nl_zeta)
6986 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
6987!
6988 IF (lscale.eq.2) THEN
6989 fac2=-facritz*dotprod(0)/cg_ritz(ninner+1-nvec,nol)
6990 END IF
6991 IF (lscale.eq.-2) THEN
6992 fac2=facritz*dotprod(0)/sqrt(cg_ritz(ninner+1-nvec,nol))
6993 END IF
6994!
6995 CALL state_addition (ng, tile, &
6996 & lbi, ubi, lbj, ubj, lbij, ubij, &
6997 & l1, l2, l1, fac1, fac2, &
6998# ifdef MASKING
6999 & rmask, umask, vmask, &
7000# endif
7001# ifdef ADJUST_BOUNDARY
7002# ifdef SOLVE3D
7003 & nl_t_obc, nl_t_obc, &
7004 & nl_u_obc, nl_u_obc, &
7005 & nl_v_obc, nl_v_obc, &
7006# endif
7007 & nl_ubar_obc, nl_ubar_obc, &
7008 & nl_vbar_obc, nl_vbar_obc, &
7009 & nl_zeta_obc, nl_zeta_obc, &
7010# endif
7011# ifdef ADJUST_WSTRESS
7012 & nl_ustr, nl_ustr, &
7013 & nl_vstr, nl_vstr, &
7014# endif
7015# ifdef SOLVE3D
7016# ifdef ADJUST_STFLUX
7017 & nl_tflux, nl_tflux, &
7018# endif
7019 & nl_t, nl_t, &
7020 & nl_u, nl_u, &
7021 & nl_v, nl_v, &
7022# else
7023 & nl_ubar, nl_ubar, &
7024 & nl_vbar, nl_vbar, &
7025# endif
7026 & nl_zeta, nl_zeta)
7027
7028 END IF
7029
7030 END DO
7031 END DO
7032!
7033 10 FORMAT (/,1x,'(',i3.3,',',i3.3,'): PRECOND -',1x, &
7034 & a,1x,'preconditioning:',1x,a/)
7035 20 FORMAT (a,'_',i3.3,'.nc')
7036 30 FORMAT (1x,'(',i3.3,',',i3.3,'): PRECOND -',1x, &
7037 & 'Reading Lanczos eigenpairs from:',t58,a)
7038 40 FORMAT (1x,'(',i3.3,',',i3.3,'): PRECOND -',1x, &
7039 & 'Number of good Ritz eigenvalues,',t58,'ingood = ',i3)
7040 50 FORMAT (1x,'(',i3.3,',',i3.3,'): PRECOND -',1x, &
7041 & 'Processing Lanczos vectors from:',t58,a)
7042 60 FORMAT (1x,'(',i3.3,',',i3.3,'): PRECOND -',1x, &
7043 & 'Processing Hessian vectors from:',t58,a)
7044!
7045 RETURN

References mod_iounits::adm, mod_iounits::calledfrom, mod_fourdvar::cg_ritz, mod_fourdvar::cg_ritzerr, mod_scalars::exit_flag, strings_mod::founderror(), mod_iounits::hss, mod_ncparam::io_nf90, mod_ncparam::io_pio, mod_fourdvar::lritz, mod_parallel::master, mod_fourdvar::nconvritz, mod_scalars::ninner, mod_scalars::noerror, mod_fourdvar::nritzev, mod_fourdvar::ritzmaxerr, mod_iounits::sourcefile, state_addition_mod::state_addition(), state_dotprod_mod::state_dotprod(), state_read_mod::state_read(), and mod_iounits::stdout.

Referenced by cgradient_tile(), and new_cost().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ tl_new_state()

subroutine, private cgradient_mod::tl_new_state ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) model,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
integer, intent(in) lbij,
integer, intent(in) ubij,
integer, intent(in) imins,
integer, intent(in) imaxs,
integer, intent(in) jmins,
integer, intent(in) jmaxs,
integer, intent(in) linp,
integer, intent(in) lout,
integer, intent(in) innloop,
integer, intent(in) outloop,
real(r8), dimension(lbi:,lbj:), intent(in) rmask,
real(r8), dimension(lbi:,lbj:), intent(in) umask,
real(r8), dimension(lbi:,lbj:), intent(in) vmask,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) d_t_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) d_u_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) d_v_obc,
real(r8), dimension(lbij:,:,:), intent(inout) d_ubar_obc,
real(r8), dimension(lbij:,:,:), intent(inout) d_vbar_obc,
real(r8), dimension(lbij:,:,:), intent(inout) d_zeta_obc,
real(r8), dimension(lbi:,lbj:,:), intent(in) d_sustr,
real(r8), dimension(lbi:,lbj:,:), intent(in) d_svstr,
real(r8), dimension(lbi:,lbj:,:,:), intent(in) d_stflx,
real(r8), dimension(lbi:,lbj:,:,:), intent(in) d_t,
real(r8), dimension(lbi:,lbj:,:), intent(in) d_u,
real(r8), dimension(lbi:,lbj:,:), intent(in) d_v,
real(r8), dimension(lbi:,lbj:), intent(in) d_zeta,
real(r8), dimension(lbij:,:,:,:,:,:), intent(inout) tl_t_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) tl_u_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) tl_v_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) tl_ubar_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) tl_vbar_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) tl_zeta_obc,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) tl_ustr,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) tl_vstr,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) tl_tflux,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) tl_t,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) tl_u,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) tl_v,
real(r8), dimension(lbi:,lbj:,:), intent(inout) tl_zeta,
real(r8), dimension(lbij:,:,:,:,:,:), intent(inout) ad_t_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) ad_u_obc,
real(r8), dimension(lbij:,:,:,:,:), intent(inout) ad_v_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) ad_ubar_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) ad_vbar_obc,
real(r8), dimension(lbij:,:,:,:), intent(inout) ad_zeta_obc,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) ad_ustr,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) ad_vstr,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) ad_tflux,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) ad_t,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) ad_u,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) ad_v,
real(r8), dimension(lbi:,lbj:,:), intent(inout) ad_zeta )
private

Definition at line 1463 of file cgradient.F.

1528!***********************************************************************
1529!
1530! Imported variable declarations.
1531!
1532 integer, intent(in) :: ng, tile, model
1533 integer, intent(in) :: LBi, UBi, LBj, UBj, LBij, UBij
1534 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
1535 integer, intent(in) :: Linp, Lout
1536 integer, intent(in) :: innLoop, outLoop
1537!
1538# ifdef ASSUMED_SHAPE
1539# ifdef MASKING
1540 real(r8), intent(in) :: rmask(LBi:,LBj:)
1541 real(r8), intent(in) :: umask(LBi:,LBj:)
1542 real(r8), intent(in) :: vmask(LBi:,LBj:)
1543# endif
1544# ifdef ADJUST_BOUNDARY
1545# ifdef SOLVE3D
1546 real(r8), intent(inout) :: d_t_obc(LBij:,:,:,:,:)
1547 real(r8), intent(inout) :: d_u_obc(LBij:,:,:,:)
1548 real(r8), intent(inout) :: d_v_obc(LBij:,:,:,:)
1549# endif
1550 real(r8), intent(inout) :: d_ubar_obc(LBij:,:,:)
1551 real(r8), intent(inout) :: d_vbar_obc(LBij:,:,:)
1552 real(r8), intent(inout) :: d_zeta_obc(LBij:,:,:)
1553# endif
1554# ifdef ADJUST_WSTRESS
1555 real(r8), intent(in) :: d_sustr(LBi:,LBj:,:)
1556 real(r8), intent(in) :: d_svstr(LBi:,LBj:,:)
1557# endif
1558# ifdef SOLVE3D
1559# ifdef ADJUST_STFLUX
1560 real(r8), intent(in) :: d_stflx(LBi:,LBj:,:,:)
1561# endif
1562 real(r8), intent(in) :: d_t(LBi:,LBj:,:,:)
1563 real(r8), intent(in) :: d_u(LBi:,LBj:,:)
1564 real(r8), intent(in) :: d_v(LBi:,LBj:,:)
1565# else
1566 real(r8), intent(in) :: d_ubar(LBi:,LBj:)
1567 real(r8), intent(in) :: d_vbar(LBi:,LBj:)
1568# endif
1569 real(r8), intent(in) :: d_zeta(LBi:,LBj:)
1570# ifdef ADJUST_BOUNDARY
1571# ifdef SOLVE3D
1572 real(r8), intent(inout) :: ad_t_obc(LBij:,:,:,:,:,:)
1573 real(r8), intent(inout) :: ad_u_obc(LBij:,:,:,:,:)
1574 real(r8), intent(inout) :: ad_v_obc(LBij:,:,:,:,:)
1575# endif
1576 real(r8), intent(inout) :: ad_ubar_obc(LBij:,:,:,:)
1577 real(r8), intent(inout) :: ad_vbar_obc(LBij:,:,:,:)
1578 real(r8), intent(inout) :: ad_zeta_obc(LBij:,:,:,:)
1579# endif
1580# ifdef ADJUST_WSTRESS
1581 real(r8), intent(inout) :: ad_ustr(LBi:,LBj:,:,:)
1582 real(r8), intent(inout) :: ad_vstr(LBi:,LBj:,:,:)
1583# endif
1584# ifdef SOLVE3D
1585# ifdef ADJUST_STFLUX
1586 real(r8), intent(inout) :: ad_tflux(LBi:,LBj:,:,:,:)
1587# endif
1588 real(r8), intent(inout) :: ad_t(LBi:,LBj:,:,:,:)
1589 real(r8), intent(inout) :: ad_u(LBi:,LBj:,:,:)
1590 real(r8), intent(inout) :: ad_v(LBi:,LBj:,:,:)
1591# else
1592 real(r8), intent(inout) :: ad_ubar(LBi:,LBj:,:)
1593 real(r8), intent(inout) :: ad_vbar(LBi:,LBj:,:)
1594# endif
1595 real(r8), intent(inout) :: ad_zeta(LBi:,LBj:,:)
1596# ifdef ADJUST_BOUNDARY
1597# ifdef SOLVE3D
1598 real(r8), intent(inout) :: tl_t_obc(LBij:,:,:,:,:,:)
1599 real(r8), intent(inout) :: tl_u_obc(LBij:,:,:,:,:)
1600 real(r8), intent(inout) :: tl_v_obc(LBij:,:,:,:,:)
1601# endif
1602 real(r8), intent(inout) :: tl_ubar_obc(LBij:,:,:,:)
1603 real(r8), intent(inout) :: tl_vbar_obc(LBij:,:,:,:)
1604 real(r8), intent(inout) :: tl_zeta_obc(LBij:,:,:,:)
1605# endif
1606# ifdef ADJUST_WSTRESS
1607 real(r8), intent(inout) :: tl_ustr(LBi:,LBj:,:,:)
1608 real(r8), intent(inout) :: tl_vstr(LBi:,LBj:,:,:)
1609# endif
1610# ifdef SOLVE3D
1611# ifdef ADJUST_STFLUX
1612 real(r8), intent(inout) :: tl_tflux(LBi:,LBj:,:,:,:)
1613# endif
1614 real(r8), intent(inout) :: tl_t(LBi:,LBj:,:,:,:)
1615 real(r8), intent(inout) :: tl_u(LBi:,LBj:,:,:)
1616 real(r8), intent(inout) :: tl_v(LBi:,LBj:,:,:)
1617# else
1618 real(r8), intent(inout) :: tl_ubar(LBi:,LBj:,:)
1619 real(r8), intent(inout) :: tl_vbar(LBi:,LBj:,:)
1620# endif
1621 real(r8), intent(inout) :: tl_zeta(LBi:,LBj:,:)
1622
1623# else
1624
1625# ifdef MASKING
1626 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
1627 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
1628 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
1629# endif
1630# ifdef ADJUST_BOUNDARY
1631# ifdef SOLVE3D
1632 real(r8), intent(in) :: d_t_obc(LBij:UBij,N(ng),4, &
1633 & Nbrec(ng),NT(ng))
1634 real(r8), intent(in) :: d_u_obc(LBij:UBij,N(ng),4,Nbrec(ng))
1635 real(r8), intent(in) :: d_v_obc(LBij:UBij,N(ng),4,Nbrec(ng))
1636# endif
1637 real(r8), intent(in) :: d_ubar_obc(LBij:UBij,4,Nbrec(ng))
1638 real(r8), intent(in) :: d_vbar_obc(LBij:UBij,4,Nbrec(ng))
1639 real(r8), intent(in) :: d_zeta_obc(LBij:UBij,4,Nbrec(ng))
1640# endif
1641# ifdef ADJUST_WSTRESS
1642 real(r8), intent(in) :: d_sustr(LBi:UBi,LBj:UBj,Nfrec(ng))
1643 real(r8), intent(in) :: d_svstr(LBi:UBi,LBj:UBj,Nfrec(ng))
1644# endif
1645# ifdef SOLVE3D
1646# ifdef ADJUST_STFLUX
1647 real(r8), intent(in) :: d_stflx(LBi:UBi,LBj:UBj, &
1648 & Nfrec(ng),NT(ng))
1649# endif
1650 real(r8), intent(in) :: d_t(LBi:UBi,LBj:UBj,N(ng),NT(ng))
1651 real(r8), intent(in) :: d_u(LBi:UBi,LBj:UBj,N(ng))
1652 real(r8), intent(in) :: d_v(LBi:UBi,LBj:UBj,N(ng))
1653# else
1654 real(r8), intent(in) :: d_ubar(LBi:UBi,LBj:UBj)
1655 real(r8), intent(in) :: d_vbar(LBi:UBi,LBj:UBj)
1656# endif
1657 real(r8), intent(in) :: d_zeta(LBi:UBi,LBj:UBj)
1658# ifdef ADJUST_BOUNDARY
1659# ifdef SOLVE3D
1660 real(r8), intent(inout) :: ad_t_obc(LBij:UBij,N(ng),4, &
1661 & Nbrec(ng),2,NT(ng))
1662 real(r8), intent(inout) :: ad_u_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
1663 real(r8), intent(inout) :: ad_v_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
1664# endif
1665 real(r8), intent(inout) :: ad_ubar_obc(LBij:UBij,4,Nbrec(ng),2)
1666 real(r8), intent(inout) :: ad_vbar_obc(LBij:UBij,4,Nbrec(ng),2)
1667 real(r8), intent(inout) :: ad_zeta_obc(LBij:UBij,4,Nbrec(ng),2)
1668# endif
1669# ifdef ADJUST_WSTRESS
1670 real(r8), intent(inout) :: ad_ustr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
1671 real(r8), intent(inout) :: ad_vstr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
1672# endif
1673# ifdef SOLVE3D
1674# ifdef ADJUST_STFLUX
1675 real(r8), intent(inout) :: ad_tflux(LBi:UBi,LBj:UBj, &
1676 & Nfrec(ng),2,NT(ng))
1677# endif
1678 real(r8), intent(inout) :: ad_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
1679 real(r8), intent(inout) :: ad_u(LBi:UBi,LBj:UBj,N(ng),2)
1680 real(r8), intent(inout) :: ad_v(LBi:UBi,LBj:UBj,N(ng),2)
1681# else
1682 real(r8), intent(inout) :: ad_ubar(LBi:UBi,LBj:UBj,:)
1683 real(r8), intent(inout) :: ad_vbar(LBi:UBi,LBj:UBj,:)
1684# endif
1685 real(r8), intent(inout) :: ad_zeta(LBi:UBi,LBj:UBj,:)
1686# ifdef ADJUST_BOUNDARY
1687# ifdef SOLVE3D
1688 real(r8), intent(inout) :: tl_t_obc(LBij:UBij,N(ng),4, &
1689 & Nbrec(ng),2,NT(ng))
1690 real(r8), intent(inout) :: tl_u_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
1691 real(r8), intent(inout) :: tl_v_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
1692# endif
1693 real(r8), intent(inout) :: tl_ubar_obc(LBij:UBij,4,Nbrec(ng),2)
1694 real(r8), intent(inout) :: tl_vbar_obc(LBij:UBij,4,Nbrec(ng),2)
1695 real(r8), intent(inout) :: tl_zeta_obc(LBij:UBij,4,Nbrec(ng),2)
1696# endif
1697# ifdef ADJUST_WSTRESS
1698 real(r8), intent(inout) :: tl_ustr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
1699 real(r8), intent(inout) :: tl_vstr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
1700# endif
1701# ifdef SOLVE3D
1702# ifdef ADJUST_STFLUX
1703 real(r8), intent(inout) :: tl_tflux(LBi:UBi,LBj:UBj, &
1704 & Nfrec(ng),2,NT(ng))
1705# endif
1706 real(r8), intent(inout) :: tl_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
1707 real(r8), intent(inout) :: tl_u(LBi:UBi,LBj:UBj,N(ng),2)
1708 real(r8), intent(inout) :: tl_v(LBi:UBi,LBj:UBj,N(ng),2)
1709# else
1710 real(r8), intent(inout) :: tl_ubar(LBi:UBi,LBj:UBj,:)
1711 real(r8), intent(inout) :: tl_vbar(LBi:UBi,LBj:UBj,:)
1712# endif
1713 real(r8), intent(inout) :: tl_zeta(LBi:UBi,LBj:UBj,:)
1714# endif
1715!
1716! Local variable declarations.
1717!
1718 integer :: i, j, k, rec
1719 integer :: ib, ir, it
1720!
1721 real(r8) :: fac, fac1, fac2
1722!
1723 character (len=256) :: ncname
1724
1725 character (len=*), parameter :: MyFile = &
1726 & __FILE__//", tl_new_state"
1727
1728# include "set_bounds.h"
1729!
1730 calledfrom=myfile
1731 sourcefile=myfile
1732!
1733!-----------------------------------------------------------------------
1734! Compute new starting tangent linear state vector, X(k+1).
1735!-----------------------------------------------------------------------
1736!
1737 IF (innloop.ne.ninner) THEN
1738!
1739! Free-surface.
1740!
1741 DO j=jstrr,jendr
1742 DO i=istrr,iendr
1743 tl_zeta(i,j,lout)=d_zeta(i,j)
1744# ifdef MASKING
1745 tl_zeta(i,j,lout)=tl_zeta(i,j,lout)*rmask(i,j)
1746# endif
1747 END DO
1748 END DO
1749
1750# ifdef ADJUST_BOUNDARY
1751!
1752! Free-surface open boundaries.
1753!
1754 IF (any(lobc(:,isfsur,ng))) THEN
1755 DO ir=1,nbrec(ng)
1756 IF ((lobc(iwest,isfsur,ng)).and. &
1757 & domain(ng)%Western_Edge(tile)) THEN
1758 ib=iwest
1759 DO j=jstr,jend
1760 tl_zeta_obc(j,ib,ir,lout)=d_zeta_obc(j,ib,ir)
1761# ifdef MASKING
1762 tl_zeta_obc(j,ib,ir,lout)=tl_zeta_obc(j,ib,ir,lout)* &
1763 & rmask(istr-1,j)
1764# endif
1765 END DO
1766 END IF
1767 IF ((lobc(ieast,isfsur,ng)).and. &
1768 & domain(ng)%Eastern_Edge(tile)) THEN
1769 ib=ieast
1770 DO j=jstr,jend
1771 tl_zeta_obc(j,ib,ir,lout)=d_zeta_obc(j,ib,ir)
1772# ifdef MASKING
1773 tl_zeta_obc(j,ib,ir,lout)=tl_zeta_obc(j,ib,ir,lout)* &
1774 & rmask(iend+1,j)
1775# endif
1776 END DO
1777 END IF
1778 IF ((lobc(isouth,isfsur,ng)).and. &
1779 & domain(ng)%Southern_Edge(tile)) THEN
1780 ib=isouth
1781 DO i=istr,iend
1782 tl_zeta_obc(i,ib,ir,lout)=d_zeta_obc(i,ib,ir)
1783# ifdef MASKING
1784 tl_zeta_obc(i,ib,ir,lout)=tl_zeta_obc(i,ib,ir,lout)* &
1785 & rmask(i,jstr-1)
1786# endif
1787 END DO
1788 END IF
1789 IF ((lobc(inorth,isfsur,ng)).and. &
1790 & domain(ng)%Northern_Edge(tile)) THEN
1791 ib=inorth
1792 DO i=istr,iend
1793 tl_zeta_obc(i,ib,ir,lout)=d_zeta_obc(i,ib,ir)
1794# ifdef MASKING
1795 tl_zeta_obc(i,ib,ir,lout)=tl_zeta_obc(i,ib,ir,lout)* &
1796 & rmask(i,jend+1)
1797# endif
1798 END DO
1799 END IF
1800 END DO
1801 END IF
1802# endif
1803
1804# ifndef SOLVE3D
1805!
1806! 2D U-momentum.
1807!
1808 DO j=jstrr,jendr
1809 DO i=istr,iendr
1810 tl_ubar(i,j,lout)=d_ubar(i,j)
1811# ifdef MASKING
1812 tl_ubar(i,j,lout)=tl_ubar(i,j,lout)*umask(i,j)
1813# endif
1814 END DO
1815 END DO
1816# endif
1817
1818# ifdef ADJUST_BOUNDARY
1819!
1820! 2D U-momentum open boundaries.
1821!
1822 IF (any(lobc(:,isubar,ng))) THEN
1823 DO ir=1,nbrec(ng)
1824 IF ((lobc(iwest,isubar,ng)).and. &
1825 & domain(ng)%Western_Edge(tile)) THEN
1826 ib=iwest
1827 DO j=jstr,jend
1828 tl_ubar_obc(j,ib,ir,lout)=d_ubar_obc(j,ib,ir)
1829# ifdef MASKING
1830 tl_ubar_obc(j,ib,ir,lout)=tl_ubar_obc(j,ib,ir,lout)* &
1831 & umask(istr,j)
1832# endif
1833 END DO
1834 END IF
1835 IF ((lobc(ieast,isubar,ng)).and. &
1836 & domain(ng)%Eastern_Edge(tile)) THEN
1837 ib=ieast
1838 DO j=jstr,jend
1839 tl_ubar_obc(j,ib,ir,lout)=d_ubar_obc(j,ib,ir)
1840# ifdef MASKING
1841 tl_ubar_obc(j,ib,ir,lout)=tl_ubar_obc(j,ib,ir,lout)* &
1842 & umask(iend+1,j)
1843# endif
1844 END DO
1845 END IF
1846 IF ((lobc(isouth,isubar,ng)).and. &
1847 & domain(ng)%Southern_Edge(tile)) THEN
1848 ib=isouth
1849 DO i=istru,iend
1850 tl_ubar_obc(i,ib,ir,lout)=d_ubar_obc(i,ib,ir)
1851# ifdef MASKING
1852 tl_ubar_obc(i,ib,ir,lout)=tl_ubar_obc(i,ib,ir,lout)* &
1853 & umask(i,jstr-1)
1854# endif
1855 END DO
1856 END IF
1857 IF ((lobc(inorth,isubar,ng)).and. &
1858 & domain(ng)%Northern_Edge(tile)) THEN
1859 ib=inorth
1860 DO i=istru,iend
1861 tl_ubar_obc(i,ib,ir,lout)=d_ubar_obc(i,ib,ir)
1862# ifdef MASKING
1863 tl_ubar_obc(i,ib,ir,lout)=tl_ubar_obc(i,ib,ir,lout)* &
1864 & umask(i,jend+1)
1865# endif
1866 END DO
1867 END IF
1868 END DO
1869 END IF
1870# endif
1871
1872# ifndef SOLVE3D
1873!
1874! 2D V-momentum.
1875!
1876 DO j=jstr,jendr
1877 DO i=istrr,iendr
1878 tl_vbar(i,j,lout)=d_vbar(i,j)
1879# ifdef MASKING
1880 tl_vbar(i,j,lout)=tl_vbar(i,j,lout)*vmask(i,j)
1881# endif
1882 END DO
1883 END DO
1884# endif
1885
1886# ifdef ADJUST_BOUNDARY
1887!
1888! 2D V-momentum open boundaries.
1889!
1890 IF (any(lobc(:,isvbar,ng))) THEN
1891 DO ir=1,nbrec(ng)
1892 IF ((lobc(iwest,isvbar,ng)).and. &
1893 & domain(ng)%Western_Edge(tile)) THEN
1894 ib=iwest
1895 DO j=jstrv,jend
1896 tl_vbar_obc(j,ib,ir,lout)=d_vbar_obc(j,ib,ir)
1897# ifdef MASKING
1898 tl_vbar_obc(j,ib,ir,lout)=tl_vbar_obc(j,ib,ir,lout)* &
1899 & vmask(istr-1,j)
1900# endif
1901 END DO
1902 END IF
1903 IF ((lobc(ieast,isvbar,ng)).and. &
1904 & domain(ng)%Eastern_Edge(tile)) THEN
1905 ib=ieast
1906 DO j=jstrv,jend
1907 tl_vbar_obc(j,ib,ir,lout)=d_vbar_obc(j,ib,ir)
1908# ifdef MASKING
1909 tl_vbar_obc(j,ib,ir,lout)=tl_vbar_obc(j,ib,ir,lout)* &
1910 & vmask(iend+1,j)
1911# endif
1912 END DO
1913 END IF
1914 IF ((lobc(isouth,isvbar,ng)).and. &
1915 & domain(ng)%Southern_Edge(tile)) THEN
1916 ib=isouth
1917 DO i=istr,iend
1918 tl_vbar_obc(i,ib,ir,lout)=d_vbar_obc(i,ib,ir)
1919# ifdef MASKING
1920 tl_vbar_obc(i,ib,ir,lout)=tl_vbar_obc(i,ib,ir,lout)* &
1921 & vmask(i,jstr)
1922# endif
1923 END DO
1924 END IF
1925 IF ((lobc(inorth,isvbar,ng)).and. &
1926 & domain(ng)%Northern_Edge(tile)) THEN
1927 ib=inorth
1928 DO i=istr,iend
1929 tl_vbar_obc(i,ib,ir,lout)=d_vbar_obc(i,ib,ir)
1930# ifdef MASKING
1931 tl_vbar_obc(i,ib,ir,lout)=tl_vbar_obc(i,ib,ir,lout)* &
1932 & vmask(i,jend+1)
1933# endif
1934 END DO
1935 END IF
1936 END DO
1937 END IF
1938# endif
1939
1940# ifdef ADJUST_WSTRESS
1941!
1942! Surface momentum stress.
1943!
1944 DO ir=1,nfrec(ng)
1945 DO j=jstrr,jendr
1946 DO i=istr,iendr
1947 tl_ustr(i,j,ir,lout)=d_sustr(i,j,ir)
1948# ifdef MASKING
1949 tl_ustr(i,j,ir,lout)=tl_ustr(i,j,ir,lout)*umask(i,j)
1950# endif
1951 END DO
1952 END DO
1953 DO j=jstr,jendr
1954 DO i=istrr,iendr
1955 tl_vstr(i,j,ir,lout)=d_svstr(i,j,ir)
1956# ifdef MASKING
1957 tl_vstr(i,j,ir,lout)=tl_vstr(i,j,ir,lout)*vmask(i,j)
1958# endif
1959 END DO
1960 END DO
1961 END DO
1962# endif
1963
1964# ifdef SOLVE3D
1965!
1966! 3D U-momentum.
1967!
1968 DO k=1,n(ng)
1969 DO j=jstrr,jendr
1970 DO i=istr,iendr
1971 tl_u(i,j,k,lout)=d_u(i,j,k)
1972# ifdef MASKING
1973 tl_u(i,j,k,lout)=tl_u(i,j,k,lout)*umask(i,j)
1974# endif
1975 END DO
1976 END DO
1977 END DO
1978
1979# ifdef ADJUST_BOUNDARY
1980!
1981! 3D U-momentum open boundaries.
1982!
1983 IF (any(lobc(:,isuvel,ng))) THEN
1984 DO ir=1,nbrec(ng)
1985 IF ((lobc(iwest,isuvel,ng)).and. &
1986 & domain(ng)%Western_Edge(tile)) THEN
1987 ib=iwest
1988 DO k=1,n(ng)
1989 DO j=jstr,jend
1990 tl_u_obc(j,k,ib,ir,lout)=d_u_obc(j,k,ib,ir)
1991# ifdef MASKING
1992 tl_u_obc(j,k,ib,ir,lout)=tl_u_obc(j,k,ib,ir,lout)* &
1993 & umask(istr,j)
1994# endif
1995 END DO
1996 END DO
1997 END IF
1998 IF ((lobc(ieast,isuvel,ng)).and. &
1999 & domain(ng)%Eastern_Edge(tile)) THEN
2000 ib=ieast
2001 DO k=1,n(ng)
2002 DO j=jstr,jend
2003 tl_u_obc(j,k,ib,ir,lout)=d_u_obc(j,k,ib,ir)
2004# ifdef MASKING
2005 tl_u_obc(j,k,ib,ir,lout)=tl_u_obc(j,k,ib,ir,lout)* &
2006 & umask(iend+1,j)
2007# endif
2008 END DO
2009 END DO
2010 END IF
2011 IF ((lobc(isouth,isuvel,ng)).and. &
2012 & domain(ng)%Southern_Edge(tile)) THEN
2013 ib=isouth
2014 DO k=1,n(ng)
2015 DO i=istru,iend
2016 tl_u_obc(i,k,ib,ir,lout)=d_u_obc(i,k,ib,ir)
2017# ifdef MASKING
2018 tl_u_obc(i,k,ib,ir,lout)=tl_u_obc(i,k,ib,ir,lout)* &
2019 & umask(i,jstr-1)
2020# endif
2021 END DO
2022 END DO
2023 END IF
2024 IF ((lobc(inorth,isuvel,ng)).and. &
2025 & domain(ng)%Northern_Edge(tile)) THEN
2026 ib=inorth
2027 DO k=1,n(ng)
2028 DO i=istru,iend
2029 tl_u_obc(i,k,ib,ir,lout)=d_u_obc(i,k,ib,ir)
2030# ifdef MASKING
2031 tl_u_obc(i,k,ib,ir,lout)=tl_u_obc(i,k,ib,ir,lout)* &
2032 & umask(i,jend+1)
2033# endif
2034 END DO
2035 END DO
2036 END IF
2037 END DO
2038 END IF
2039# endif
2040!
2041! 3D V-momentum.
2042!
2043 DO k=1,n(ng)
2044 DO j=jstr,jendr
2045 DO i=istrr,iendr
2046 tl_v(i,j,k,lout)=d_v(i,j,k)
2047# ifdef MASKING
2048 tl_v(i,j,k,lout)=tl_v(i,j,k,lout)*vmask(i,j)
2049# endif
2050 END DO
2051 END DO
2052 END DO
2053
2054# ifdef ADJUST_BOUNDARY
2055!
2056! 3D V-momentum open boundaries.
2057!
2058 IF (any(lobc(:,isvvel,ng))) THEN
2059 DO ir=1,nbrec(ng)
2060 IF ((lobc(iwest,isvvel,ng)).and. &
2061 & domain(ng)%Western_Edge(tile)) THEN
2062 ib=iwest
2063 DO k=1,n(ng)
2064 DO j=jstrv,jend
2065 tl_v_obc(j,k,ib,ir,lout)=d_v_obc(j,k,ib,ir)
2066# ifdef MASKING
2067 tl_v_obc(j,k,ib,ir,lout)=tl_v_obc(j,k,ib,ir,lout)* &
2068 & vmask(istr-1,j)
2069# endif
2070 END DO
2071 END DO
2072 END IF
2073 IF ((lobc(ieast,isvvel,ng)).and. &
2074 & domain(ng)%Eastern_Edge(tile)) THEN
2075 ib=ieast
2076 DO k=1,n(ng)
2077 DO j=jstrv,jend
2078 tl_v_obc(j,k,ib,ir,lout)=d_v_obc(j,k,ib,ir)
2079# ifdef MASKING
2080 tl_v_obc(j,k,ib,ir,lout)=tl_v_obc(j,k,ib,ir,lout)* &
2081 & vmask(iend+1,j)
2082# endif
2083 END DO
2084 END DO
2085 END IF
2086 IF ((lobc(isouth,isvvel,ng)).and. &
2087 & domain(ng)%Southern_Edge(tile)) THEN
2088 ib=isouth
2089 DO k=1,n(ng)
2090 DO i=istr,iend
2091 tl_v_obc(i,k,ib,ir,lout)=d_v_obc(i,k,ib,ir)
2092# ifdef MASKING
2093 tl_v_obc(i,k,ib,ir,lout)=tl_v_obc(i,k,ib,ir,lout)* &
2094 & vmask(i,jstr)
2095# endif
2096 END DO
2097 END DO
2098 END IF
2099 IF ((lobc(inorth,isvvel,ng)).and. &
2100 & domain(ng)%Northern_Edge(tile)) THEN
2101 ib=inorth
2102 DO k=1,n(ng)
2103 DO i=istr,iend
2104 tl_v_obc(i,k,ib,ir,lout)=d_v_obc(i,k,ib,ir)
2105# ifdef MASKING
2106 tl_v_obc(i,k,ib,ir,lout)=tl_v_obc(i,k,ib,ir,lout)* &
2107 & vmask(i,jend+1)
2108# endif
2109 END DO
2110 END DO
2111 END IF
2112 END DO
2113 END IF
2114# endif
2115!
2116! Tracers.
2117!
2118 DO it=1,nt(ng)
2119 DO k=1,n(ng)
2120 DO j=jstrr,jendr
2121 DO i=istrr,iendr
2122 tl_t(i,j,k,lout,it)=d_t(i,j,k,it)
2123# ifdef MASKING
2124 tl_t(i,j,k,lout,it)=tl_t(i,j,k,lout,it)*rmask(i,j)
2125# endif
2126 END DO
2127 END DO
2128 END DO
2129 END DO
2130
2131# ifdef ADJUST_BOUNDARY
2132!
2133! Tracers open boundaries.
2134!
2135 DO it=1,nt(ng)
2136 IF (any(lobc(:,istvar(it),ng))) THEN
2137 DO ir=1,nbrec(ng)
2138 IF ((lobc(iwest,istvar(it),ng)).and. &
2139 & domain(ng)%Western_Edge(tile)) THEN
2140 ib=iwest
2141 DO k=1,n(ng)
2142 DO j=jstr,jend
2143 tl_t_obc(j,k,ib,ir,lout,it)=d_t_obc(j,k,ib,ir,it)
2144# ifdef MASKING
2145 tl_t_obc(j,k,ib,ir,lout,it)= &
2146 & tl_t_obc(j,k,ib,ir,lout,it)*rmask(istr-1,j)
2147# endif
2148 END DO
2149 END DO
2150 END IF
2151 IF ((lobc(ieast,istvar(it),ng)).and. &
2152 & domain(ng)%Eastern_Edge(tile)) THEN
2153 ib=ieast
2154 DO k=1,n(ng)
2155 DO j=jstr,jend
2156 tl_t_obc(j,k,ib,ir,lout,it)=d_t_obc(j,k,ib,ir,it)
2157# ifdef MASKING
2158 tl_t_obc(j,k,ib,ir,lout,it)= &
2159 & tl_t_obc(j,k,ib,ir,lout,it)*rmask(iend+1,j)
2160# endif
2161 END DO
2162 END DO
2163 END IF
2164 IF ((lobc(isouth,istvar(it),ng)).and. &
2165 & domain(ng)%Southern_Edge(tile)) THEN
2166 ib=isouth
2167 DO k=1,n(ng)
2168 DO i=istr,iend
2169 tl_t_obc(i,k,ib,ir,lout,it)=d_t_obc(i,k,ib,ir,it)
2170# ifdef MASKING
2171 tl_t_obc(i,k,ib,ir,lout,it)= &
2172 & tl_t_obc(i,k,ib,ir,lout,it)*rmask(i,jstr-1)
2173# endif
2174 END DO
2175 END DO
2176 END IF
2177 IF ((lobc(inorth,istvar(it),ng)).and. &
2178 & domain(ng)%Northern_Edge(tile)) THEN
2179 ib=inorth
2180 DO k=1,n(ng)
2181 DO i=istr,iend
2182 tl_t_obc(i,k,ib,ir,lout,it)=d_t_obc(i,k,ib,ir,it)
2183# ifdef MASKING
2184 tl_t_obc(i,k,ib,ir,lout,it)= &
2185 & tl_t_obc(i,k,ib,ir,lout,it)*rmask(i,jend+1)
2186# endif
2187 END DO
2188 END DO
2189 END IF
2190 END DO
2191 END IF
2192 END DO
2193# endif
2194
2195# ifdef ADJUST_STFLUX
2196!
2197! Surface tracers flux.
2198!
2199 DO it=1,nt(ng)
2200 IF (lstflux(it,ng)) THEN
2201 DO ir=1,nfrec(ng)
2202 DO j=jstrr,jendr
2203 DO i=istrr,iendr
2204 tl_tflux(i,j,ir,lout,it)=d_stflx(i,j,ir,it)
2205# ifdef MASKING
2206 tl_tflux(i,j,ir,lout,it)=tl_tflux(i,j,ir,lout,it)* &
2207 & rmask(i,j)
2208# endif
2209 END DO
2210 END DO
2211 END DO
2212 END IF
2213 END DO
2214# endif
2215
2216# endif
2217!
2218!-----------------------------------------------------------------------
2219! If last inner-loop, compute the tangent linear model initial
2220! conditions from the Lanczos algorithm. Use adjoint state arrays,
2221! index Linp, as temporary storage.
2222!-----------------------------------------------------------------------
2223!
2224 ELSE
2225!
2226! Clear the adjoint working arrays (index Linp) since the tangent
2227! linear model initial condition on the first inner-loop is zero:
2228!
2229! ad_var(Linp) = fac
2230!
2231 fac=0.0_r8
2232
2233 CALL state_initialize (ng, tile, &
2234 & lbi, ubi, lbj, ubj, lbij, ubij, &
2235 & linp, fac, &
2236# ifdef MASKING
2237 & rmask, umask, vmask, &
2238# endif
2239# ifdef ADJUST_BOUNDARY
2240# ifdef SOLVE3D
2241 & ad_t_obc, ad_u_obc, ad_v_obc, &
2242# endif
2243 & ad_ubar_obc, ad_vbar_obc, &
2244 & ad_zeta_obc, &
2245# endif
2246# ifdef ADJUST_WSTRESS
2247 & ad_ustr, ad_vstr, &
2248# endif
2249# ifdef SOLVE3D
2250# ifdef ADJUST_STFLUX
2251 & ad_tflux, &
2252# endif
2253 & ad_t, ad_u, ad_v, &
2254# else
2255 & ad_ubar, ad_vbar, &
2256# endif
2257 & ad_zeta)
2258!
2259! Read in each previous gradient state solutions, g(0) to g(k).
2260!
2261 IF (ndefadj(ng).gt.0) THEN
2262 WRITE (ncname,10) trim(adm(ng)%base), outloop
2263 10 FORMAT (a,'_',i3.3,'.nc')
2264 ELSE
2265 ncname=adm(ng)%name
2266 END IF
2267!
2268 DO rec=1,innloop
2269!
2270! Read gradient solution and load it into TANGENT LINEAR STATE ARRAYS
2271! at index Lout.
2272!
2273 CALL state_read (ng, tile, model, adm(ng)%IOtype, &
2274 & lbi, ubi, lbj, ubj, lbij, ubij, &
2275 & lout, rec, &
2276 & ndefadj(ng), adm(ng)%ncid, &
2277# if defined PIO_LIB && defined DISTRIBUTE
2278 & adm(ng)%pioFile, &
2279# endif
2280 & ncname, &
2281# ifdef MASKING
2282 & rmask, umask, vmask, &
2283# endif
2284# ifdef ADJUST_BOUNDARY
2285# ifdef SOLVE3D
2286 & tl_t_obc, tl_u_obc, tl_v_obc, &
2287# endif
2288 & tl_ubar_obc, tl_vbar_obc, &
2289 & tl_zeta_obc, &
2290# endif
2291# ifdef ADJUST_WSTRESS
2292 & tl_ustr, tl_vstr, &
2293# endif
2294# ifdef SOLVE3D
2295# ifdef ADJUST_STFLUX
2296 & tl_tflux, &
2297# endif
2298 & tl_t, tl_u, tl_v, &
2299# else
2300 & tl_ubar, tl_vbar, &
2301# endif
2302 & tl_zeta)
2303 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
2304!
2305! Sum all previous normalized gradients:
2306!
2307! ad_var(Linp) = fac1 * ad_var(Linp) + fac2 * tl_var(Lout)
2308!
2309 fac1=1.0_r8
2310 fac2=cg_zu(rec,outloop)
2311
2312 CALL state_addition (ng, tile, &
2313 & lbi, ubi, lbj, ubj, lbij, ubij, &
2314 & linp, lout, linp, fac1, fac2, &
2315# ifdef MASKING
2316 & rmask, umask, vmask, &
2317# endif
2318# ifdef ADJUST_BOUNDARY
2319# ifdef SOLVE3D
2320 & ad_t_obc, tl_t_obc, &
2321 & ad_u_obc, tl_u_obc, &
2322 & ad_v_obc, tl_v_obc, &
2323# endif
2324 & ad_ubar_obc, tl_ubar_obc, &
2325 & ad_vbar_obc, tl_vbar_obc, &
2326 & ad_zeta_obc, tl_zeta_obc, &
2327# endif
2328# ifdef ADJUST_WSTRESS
2329 & ad_ustr, tl_ustr, &
2330 & ad_vstr, tl_vstr, &
2331# endif
2332# ifdef SOLVE3D
2333# ifdef ADJUST_STFLUX
2334 & ad_tflux, tl_tflux, &
2335# endif
2336 & ad_t, tl_t, &
2337 & ad_u, tl_u, &
2338 & ad_v, tl_v, &
2339# else
2340 & ad_ubar, tl_ubar, &
2341 & ad_vbar, tl_vbar, &
2342# endif
2343 & ad_zeta, tl_zeta)
2344 END DO
2345!
2346! Load new tangent linear model initial conditions to respective state
2347! arrays, index Lout:
2348!
2349! tl_var(Lout) = ad_var(Linp)
2350!
2351 CALL state_copy (ng, tile, &
2352 & lbi, ubi, lbj, ubj, lbij, ubij, &
2353 & linp, lout, &
2354# ifdef ADJUST_BOUNDARY
2355# ifdef SOLVE3D
2356 & tl_t_obc, ad_t_obc, &
2357 & tl_u_obc, ad_u_obc, &
2358 & tl_v_obc, ad_v_obc, &
2359# endif
2360 & tl_ubar_obc, ad_ubar_obc, &
2361 & tl_vbar_obc, ad_vbar_obc, &
2362 & tl_zeta_obc, ad_zeta_obc, &
2363# endif
2364# ifdef ADJUST_WSTRESS
2365 & tl_ustr, ad_ustr, &
2366 & tl_vstr, ad_vstr, &
2367# endif
2368# ifdef SOLVE3D
2369# ifdef ADJUST_STFLUX
2370 & tl_tflux, ad_tflux, &
2371# endif
2372 & tl_t, ad_t, &
2373 & tl_u, ad_u, &
2374 & tl_v, ad_v, &
2375# else
2376 & tl_ubar, ad_ubar, &
2377 & tl_vbar, ad_vbar, &
2378# endif
2379 & tl_zeta, ad_zeta)
2380 END IF
2381!
2382 RETURN

References mod_iounits::adm, mod_iounits::calledfrom, mod_fourdvar::cg_zu, mod_param::domain, mod_scalars::exit_flag, strings_mod::founderror(), mod_scalars::ieast, mod_scalars::inorth, mod_ncparam::isfsur, mod_scalars::isouth, mod_ncparam::istvar, mod_ncparam::isubar, mod_ncparam::isuvel, mod_ncparam::isvbar, mod_ncparam::isvvel, mod_scalars::iwest, mod_scalars::lobc, mod_scalars::lstflux, mod_param::n, mod_scalars::nbrec, mod_scalars::ndefadj, mod_scalars::nfrec, mod_scalars::ninner, mod_scalars::noerror, mod_param::nt, mod_iounits::sourcefile, state_addition_mod::state_addition(), state_copy_mod::state_copy(), state_initialize_mod::state_initialize(), and state_read_mod::state_read().

Referenced by cgradient_tile().

Here is the call graph for this function:
Here is the caller graph for this function: