From e542b601154df2a2291468e086f0114e96e291e6 Mon Sep 17 00:00:00 2001 From: pdicerbo Date: Tue, 31 May 2016 17:06:33 +0200 Subject: [PATCH] adding all fortran sources --- bmd_str.f90 | 109 ++ cns_str.f90 | 58 + cnv_ctv.f90 | 67 + cnv_ctv_ad.f90 | 62 + cnv_inn.f90 | 48 + costf.f90 | 106 ++ ctl_str.f90 | 72 + def_cov.f90 | 311 +++ def_grd.f90 | 120 ++ def_nml.f90 | 247 +++ drv_str.f90 | 68 + eof_str.f90 | 61 + filename_mod.f90 | 35 + get_obs.f90 | 76 + get_obs_chl.f90 | 274 +++ grd_str.f90 | 136 ++ ini_bmd.f90 | 173 ++ ini_cfn.f90 | 103 + ini_itr.f90 | 133 ++ ini_nrm.f90 | 71 + int_par.f90 | 75 + main.f90 | 8 + min_cfn.f90 | 90 + netcdf_err.f90 | 38 + obs_chl.f90 | 63 + obs_chl_ad.f90 | 63 + obs_str.f90 | 475 +++++ obs_vec.f90 | 154 ++ obsop.f90 | 75 + obsop_ad.f90 | 77 + oceanvar.f90 | 138 ++ rcfl_mod.f90 | 10 + rcfl_x.f90 | 120 ++ rcfl_x_ad.f90 | 131 ++ rcfl_y.f90 | 121 ++ rcfl_y_ad.f90 | 131 ++ rcfl_y_ad_init.f90 | 115 ++ rcfl_y_init.f90 | 106 ++ rdeofs.f90 | 110 ++ rdgrds.f90 | 192 ++ res_inc.f90 | 56 + resid.f90 | 145 ++ routines.f | 4471 ++++++++++++++++++++++++++++++++++++++++++++ sav_itr.f90 | 159 ++ set_knd.f90 | 44 + veof.f90 | 160 ++ veof_ad.f90 | 143 ++ ver_hor.f90 | 336 ++++ ver_hor_ad.f90 | 363 ++++ wrt_dia.f90 | 229 +++ 50 files changed, 10728 insertions(+) create mode 100644 bmd_str.f90 create mode 100644 cns_str.f90 create mode 100644 cnv_ctv.f90 create mode 100644 cnv_ctv_ad.f90 create mode 100644 cnv_inn.f90 create mode 100644 costf.f90 create mode 100644 ctl_str.f90 create mode 100644 def_cov.f90 create mode 100644 def_grd.f90 create mode 100644 def_nml.f90 create mode 100644 drv_str.f90 create mode 100644 eof_str.f90 create mode 100644 filename_mod.f90 create mode 100644 get_obs.f90 create mode 100644 get_obs_chl.f90 create mode 100644 grd_str.f90 create mode 100644 ini_bmd.f90 create mode 100644 ini_cfn.f90 create mode 100644 ini_itr.f90 create mode 100644 ini_nrm.f90 create mode 100644 int_par.f90 create mode 100644 main.f90 create mode 100644 min_cfn.f90 create mode 100644 netcdf_err.f90 create mode 100644 obs_chl.f90 create mode 100644 obs_chl_ad.f90 create mode 100644 obs_str.f90 create mode 100644 obs_vec.f90 create mode 100644 obsop.f90 create mode 100644 obsop_ad.f90 create mode 100644 oceanvar.f90 create mode 100644 rcfl_mod.f90 create mode 100644 rcfl_x.f90 create mode 100644 rcfl_x_ad.f90 create mode 100644 rcfl_y.f90 create mode 100644 rcfl_y_ad.f90 create mode 100644 rcfl_y_ad_init.f90 create mode 100644 rcfl_y_init.f90 create mode 100644 rdeofs.f90 create mode 100644 rdgrds.f90 create mode 100644 res_inc.f90 create mode 100644 resid.f90 create mode 100644 routines.f create mode 100644 sav_itr.f90 create mode 100644 set_knd.f90 create mode 100644 veof.f90 create mode 100644 veof_ad.f90 create mode 100644 ver_hor.f90 create mode 100644 ver_hor_ad.f90 create mode 100644 wrt_dia.f90 diff --git a/bmd_str.f90 b/bmd_str.f90 new file mode 100644 index 0000000..a0a0783 --- /dev/null +++ b/bmd_str.f90 @@ -0,0 +1,109 @@ +MODULE bmd_str + +!--------------------------------------------------------------------------- +! ! +! Copyright 2007 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Structure for the barotropic model ! +! ! +! Version 1: S.Dobricic 2007 ! +!----------------------------------------------------------------------- + + use set_knd + +implicit none + +public + + TYPE bmd_t + + INTEGER(i4) :: ncnt ! Maximum number of iterations in the implicit solver + REAL(r8) :: ovr ! Over-relaxation factor + REAL(r8) :: resem ! Stopping criteria + REAL(r8) :: bnm ! Number of sea points + + REAL(r8) :: g ! Graviational acceleration + REAL(r8) :: dt ! Time step + INTEGER(i4) :: nstp ! Number of time steps per day + REAL(r8) :: ndy ! Number of simulation days + REAL(r8) :: ady ! Number of averaging days + INTEGER(i4) :: nstps ! Number of time steps of the main loop + INTEGER(i4) :: nstpa ! Number of time steps for averaging + REAL(r8) :: alp1 ! Weighting factor in the trapezoidal scheme + REAL(r8) :: alp2 ! Weighting factor in the trapezoidal scheme + REAL(r8) :: fc1 ! Friction intensity + REAL(r8) :: fc2 ! Friction intensity + REAL(r8) :: df1 ! Friction intensity + REAL(r8) :: df2 ! Friction intensity + + INTEGER(i4), POINTER :: itr(:) ! Number of iterations in the solver + REAL(r8), POINTER :: mst(:,:) ! Sea-land mask on t points + REAL(r8), POINTER :: msu(:,:) ! Sea-land mask on u points + REAL(r8), POINTER :: msv(:,:) ! Sea-land mask on v points + REAL(r8), POINTER :: hgt(:,:) ! Depth on t points + REAL(r8), POINTER :: hgu(:,:) ! Depth on u points + REAL(r8), POINTER :: hgv(:,:) ! Depth on v points + REAL(r8), POINTER :: dxu(:,:) ! DX on u points + REAL(r8), POINTER :: dyu(:,:) ! DY on u points + REAL(r8), POINTER :: dxv(:,:) ! DX on v points + REAL(r8), POINTER :: dyv(:,:) ! DY on v points + REAL(r8), POINTER :: a1(:,:) ! Constant + REAL(r8), POINTER :: a2(:,:) ! Constant + REAL(r8), POINTER :: a3(:,:) ! Constant + REAL(r8), POINTER :: a4(:,:) ! Constant + REAL(r8), POINTER :: a0(:,:) ! Constant + REAL(r8), POINTER :: a00(:,:) ! Constant + REAL(r8), POINTER :: bx(:,:) ! Bouyancy gradient in x direction (vert. int.) + REAL(r8), POINTER :: by(:,:) ! Bouyancy gradient in y direction (vert. int.) + REAL(r8), POINTER :: b_x(:,:,:) ! Bouyancy gradient in x direction + REAL(r8), POINTER :: b_y(:,:,:) ! Bouyancy gradient in y direction + REAL(r8), POINTER :: dns(:,:,:) ! Density + REAL(r8), POINTER :: bxby(:,:) ! + REAL(r8), POINTER :: rgh(:,:) ! + REAL(r8), POINTER :: etb(:,:) ! Eta at t-1 + REAL(r8), POINTER :: ub(:,:) ! U at t-1 + REAL(r8), POINTER :: vb(:,:) ! V at t-1 + REAL(r8), POINTER :: etn(:,:) ! Eta at t + REAL(r8), POINTER :: un(:,:) ! U at t + REAL(r8), POINTER :: vn(:,:) ! V at t + REAL(r8), POINTER :: eta(:,:) ! Eta at t+1 + REAL(r8), POINTER :: ua(:,:) ! U at t+1 + REAL(r8), POINTER :: va(:,:) ! V at t+1 + REAL(r8), POINTER :: etm(:,:) ! Averaged eta + REAL(r8), POINTER :: um(:,:) ! Averaged u + REAL(r8), POINTER :: vm(:,:) ! Averaged v + REAL(r8), POINTER :: div(:,:) ! Divergence at t-1 + REAL(r8), POINTER :: cu(:,:) ! Coriolis term on u points + REAL(r8), POINTER :: cv(:,:) ! Coriolis term on v points + REAL(r8), POINTER :: dux(:,:) ! Friction on U + REAL(r8), POINTER :: duy(:,:) ! Friction on U + REAL(r8), POINTER :: dvx(:,:) ! Friction on V + REAL(r8), POINTER :: dvy(:,:) ! Friction on V + REAL(r8), POINTER :: etx(:,:) ! Free surface gradient at t-1 + REAL(r8), POINTER :: ety(:,:) ! Free surface gradient at t-1 + + + END TYPE bmd_t + + TYPE (bmd_t) :: bmd + +END MODULE bmd_str diff --git a/cns_str.f90 b/cns_str.f90 new file mode 100644 index 0000000..9222961 --- /dev/null +++ b/cns_str.f90 @@ -0,0 +1,58 @@ +MODULE cns_str + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Structure of constants ! +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + use set_knd + +implicit none + +public + + TYPE rcf_t + + INTEGER(i4) :: ntr ! No. of iterations (half of) + REAL(r8) :: dx ! Grid resolution (m) + REAL(r8) :: L ! Correlation radius + REAL(r8) :: E ! Norm + REAL(r8) :: alp ! Filter weight + INTEGER(i4) :: ntb ! Number of points in the table + REAL(r8) :: dsmn ! Minimum distance + REAL(r8) :: dsmx ! Maximum distance + REAL(r8) :: dsl ! Table increment + REAL(r8), POINTER :: al(:) ! Filter weights in the table + REAL(r8), POINTER :: sc(:) ! Filter scaling factors in the table + REAL(r8) :: scl ! Scaling factor + REAL(r8) :: efc ! Scaling factor for extended points + INTEGER(i4) :: kstp ! Step for extended points + + END TYPE rcf_t + + TYPE (rcf_t) :: rcf + +END MODULE cns_str diff --git a/cnv_ctv.f90 b/cnv_ctv.f90 new file mode 100644 index 0000000..4f1e08a --- /dev/null +++ b/cnv_ctv.f90 @@ -0,0 +1,67 @@ +subroutine cnv_ctv + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Convert from control to v ! +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + + use set_knd + use grd_str + use ctl_str + use eof_str + + implicit none + + INTEGER(i4) :: i,j,k, kk + INTEGER(i4) :: jumpInd, indSupWP +! INTEGER(i4) mycounter +! kk = 0 +! do k=1,ros%neof +! do j=1,grd%jm +! do i=1,grd%im +! kk = kk+1 +! grd%ro(i,j,k) = ctl%x_c(kk) +! enddo +! enddo +! enddo +!mycounter = 0 + + + do k=1,ros%neof + jumpInd = (k -1 )*nSurfaceWaterPoints + do indSupWP = 1,nSurfaceWaterPoints + i = SurfaceWaterPoints(1,indSupWP) + j = SurfaceWaterPoints(2,indSupWP) + kk = jumpInd + indSupWP + grd%ro(i,j,k) = ctl%x_c(kk) + enddo + enddo + + + + +end subroutine cnv_ctv diff --git a/cnv_ctv_ad.f90 b/cnv_ctv_ad.f90 new file mode 100644 index 0000000..16c15da --- /dev/null +++ b/cnv_ctv_ad.f90 @@ -0,0 +1,62 @@ +subroutine cnv_ctv_ad + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Convert from control to v - adjoint ! +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + + use grd_str + use ctl_str + use eof_str + use netcdf + implicit none + + INTEGER(i4) :: i,j,k, kk + INTEGER(i4) :: jumpInd, indSupWP + +! integer xid,yid,eofid, idvip, status, ncid,nSFid, nDIMS, SFid +! kk = 0 +! do k=1,ros%neof +! do j=1,grd%jm +! do i=1,grd%im +! kk = kk+1 +! ctl%g_c(kk) = grd%ro_ad(i,j,k) +! enddo +! enddo +! enddo + + do k=1,ros%neof + jumpInd = (k -1 )* nSurfaceWaterPoints + do indSupWP=1,nSurfaceWaterPoints + i = SurfaceWaterPoints(1,indSupWP) + j = SurfaceWaterPoints(2,indSupWP) + kk = jumpInd + indSupWP + ctl%g_c(kk) = grd%ro_ad(i,j,k) + enddo + enddo + +end subroutine cnv_ctv_ad diff --git a/cnv_inn.f90 b/cnv_inn.f90 new file mode 100644 index 0000000..6a2d7be --- /dev/null +++ b/cnv_inn.f90 @@ -0,0 +1,48 @@ +subroutine cnv_inn + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Convert w to correction in physical space ! +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + + use set_knd + use obs_str + use grd_str + use eof_str + use ctl_str + use drv_str + + implicit none + + drv%dda(drv%ktr) = drv%ddi(drv%ktr) + +! -------- +! Convert the control vector to v + call cnv_ctv + call ver_hor + +end subroutine cnv_inn diff --git a/costf.f90 b/costf.f90 new file mode 100644 index 0000000..79e8d1a --- /dev/null +++ b/costf.f90 @@ -0,0 +1,106 @@ +subroutine costf + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Calclate the cost function and its gradient ! +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + + use set_knd + use obs_str + use grd_str + use eof_str + use ctl_str + + implicit none + +! ------------------------------------------------------- +! calculate backgorund cost term +! ------------------------------------------------------- + + ctl%f_b = 0.5 * dot_product( ctl%x_c, ctl%x_c) +! write(*,*) 'COSTF f_b = ', ctl%f_b + +! ------------------------------------------------------- +! calculate observational cost term +! ------------------------------------------------------- +! -------- +! Convert the control vector to v + call cnv_ctv + +! -------- +! Control to physical space + call ver_hor + +! -------- +! Apply observational operators + call obsop + +! -------- +! Calculate residuals + call resid + +! -------- +! calculate cost + ctl%f_o = 0.5 * dot_product( obs%amo, obs%amo) + +! ------------------------------------------------------- +! Cost function +! ------------------------------------------------------- + + ctl%f_c = ctl%f_b + ctl%f_o + + print*,' Cost function ',ctl%f_c + +! ------------------------------------------------------- +! calculate the cost function gradient +! ------------------------------------------------------- + +! -------- +! Reset the increments + call res_inc + +! -------- +! Observational operators + call obsop_ad + +! -------- +! Control to physical space + call ver_hor_ad + +! write(*,*) 'COSTF sum(ro_ad) = ' , sum(grd%ro_ad) +! -------- +! Convert the control vector + call cnv_ctv_ad + +! ------------------------------------------------------- +! Cost function gradient +! ------------------------------------------------------- + +! write(*,*) 'COSTF sum(g_c) = ' , sum( ctl%g_c) + ctl%g_c(:) = ctl%x_c(:) + ctl%g_c(:) ! OMP + +end subroutine costf diff --git a/ctl_str.f90 b/ctl_str.f90 new file mode 100644 index 0000000..20acaf5 --- /dev/null +++ b/ctl_str.f90 @@ -0,0 +1,72 @@ +MODULE ctl_str + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Cost function, control vector and optimisation arrays ! +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + use set_knd + +implicit none + +public + +! --- +! Structure for lbfgs + + TYPE lbfgs_t + + INTEGER(i4) :: n ! size of the optimisation vector + INTEGER(i4) :: m ! number of copies to be saved + CHARACTER(LEN=60) :: task, csave + LOGICAL, DIMENSION(4) :: lsave + INTEGER(i4), DIMENSION(44):: isave + INTEGER(i4), POINTER :: nbd(:), iwa(:) + INTEGER(i4) :: iprint + REAL(r8) :: f_b ! The background cost function + REAL(r8) :: f_o ! The observational cost function + real(r8) :: f_c, factr ! The cost function, accuracy + real(r8) :: pgtol, pgper ! Stopping criteria, percentage of initial gradient + real(r8), & + DIMENSION(29) :: dsave + real(r8), & + POINTER :: x_c(:) ! The control vector (background - analyses) + real(r8), & + POINTER :: g_c(:) ! The gradient of f_c + real(r8), & + POINTER :: l_c(:), u_c(:) + real(r8), & + POINTER :: wa(:), sg(:), sgo(:), yg(:), ygo(:), & + ws(:,:), wy(:,:), sy(:,:), ss(:,:), & + yy(:,:), wt(:,:), wn(:,:), snd(:,:), & + z_c(:), r_c(:), d_c(:), t_c(:) ! Working arrays + + + END TYPE lbfgs_t + + TYPE (lbfgs_t) :: ctl + +END MODULE ctl_str diff --git a/def_cov.f90 b/def_cov.f90 new file mode 100644 index 0000000..7b1356c --- /dev/null +++ b/def_cov.f90 @@ -0,0 +1,311 @@ +subroutine def_cov + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Define filter constants, EOFs, etc. ! +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + use set_knd + use drv_str + use grd_str + use eof_str + use cns_str + use rcfl + + implicit none + + INTEGER(i4) :: k, nspl, i, j, kk + REAL(r8) :: E, dst + REAL(r8) , ALLOCATABLE :: sfct(:), al(:), bt(:) + INTEGER(i4) , ALLOCATABLE :: jnxx(:) + INTEGER nthreads, threadid + integer :: OMP_GET_NUM_THREADS,OMP_GET_THREAD_NUM + +nthreads = 1 +threadid = 0 +!$OMP PARALLEL +!$ nthreads = OMP_GET_NUM_THREADS() +!$ threadid = OMP_GET_THREAD_NUM() +if(threadid.eq.0) then + write(*,*) "OMP version with threads = ", nthreads +endif +!$OMP END PARALLEL +! --- +! Recursive filter constants +!--------- +! Create table + + nspl = max(grd%jm,grd%im) + ALLOCATE ( sfct(nspl)) ; sfct = huge(sfct(1)) + ALLOCATE ( jnxx(nspl)) ; jnxx = huge(jnxx(1)) + ALLOCATE ( al(nspl)) ; al = huge(al(1)) + ALLOCATE ( bt(nspl)) ; bt = huge(bt(1)) + + + rcf%ntb = min(20,min(grd%jm,grd%im)) + +! KB grid problem (chl assimilation) + rcf%ntb = 1000 +! + + ALLOCATE ( rcf%al(rcf%ntb)) ; rcf%al = huge(rcf%al(1)) + ALLOCATE ( rcf%sc(rcf%ntb)) ; rcf%sc = huge(rcf%sc(1)) + + rcf%dsmn = 1.e20 + rcf%dsmx = -1.e20 + do j=1,grd%jm + do i=1,grd%im + rcf%dsmn = min(rcf%dsmn,min(grd%dx(i,j),grd%dy(i,j))) + rcf%dsmx = max(rcf%dsmx,max(grd%dx(i,j),grd%dy(i,j))) + enddo + enddo + + rcf%dsmx = rcf%dsmx + max(1.d0,(rcf%dsmx-rcf%dsmn)/(rcf%ntb-2.)) + + rcf%dsl = (rcf%dsmx-rcf%dsmn) / (rcf%ntb-1.) + + do k=1,rcf%ntb + dst = rcf%dsmn + (k-1.) * rcf%dsl + E = (2. * rcf%ntr) * dst**2 / (4. * rcf%L**2) + rcf%al(k) = 1. + E - sqrt(E*(E+2.)) + rcf%alp = rcf%al(k) + sfct(:) = 0. + al(:) = rcf%al(k) + bt(:) = rcf%al(k) + do j=1,nspl + jnxx(j) = j + enddo + sfct(nspl/2+1) = 1. + call rcfl_y_init ( 1, nspl, 1, nspl, al, bt, sfct, jnxx, nspl) + call rcfl_y_ad_init ( 1, nspl, 1, nspl, al, bt, sfct, jnxx, nspl) + rcf%sc(k) = sfct(nspl/2+1) + enddo + + DEALLOCATE ( sfct, jnxx, al, bt ) + + do j=1,grd%jm + do i=1,grd%im + dst = ( grd%dx(i,j) - rcf%dsmn )/rcf%dsl + k = int(dst) + 1 + dst = dst - real(k-1) + grd%scx(i,j) = sqrt( 1./ (rcf%sc(k)*(1.-dst) + rcf%sc(k+1)*dst) ) + dst = ( grd%dy(i,j) - rcf%dsmn )/rcf%dsl + k = int(dst) + 1 + dst = dst - real(k-1) + grd%scy(i,j) = sqrt( 1./ (rcf%sc(k)*(1.-dst) + rcf%sc(k+1)*dst) ) + enddo + enddo + + do j=1,grd%jm + do i=2,grd%im + dst = (grd%dx(i-1,j) + grd%dx(i,j)) * 0.5 + E = (2. * rcf%ntr) * dst**2 / (4. * rcf%L**2) + grd%alx(i,j) = 1. + E - sqrt(E*(E+2.)) + enddo + do i=1,grd%im-1 + dst = (grd%dx(i,j) + grd%dx(i+1,j)) * 0.5 + E = (2. * rcf%ntr) * dst**2 / (4. * rcf%L**2) + grd%btx(i,j) = 1. + E - sqrt(E*(E+2.)) + enddo + enddo + + do j=2,grd%jm + do i=1,grd%im + dst = (grd%dy(i,j-1) + grd%dy(i,j)) * 0.5 + E = (2. * rcf%ntr) * dst**2 / (4. * rcf%L**2) + grd%aly(i,j) = 1. + E - sqrt(E*(E+2.)) + enddo + enddo + do j=1,grd%jm-1 + do i=1,grd%im + dst = (grd%dy(i,j) + grd%dy(i,j+1)) * 0.5 + E = (2. * rcf%ntr) * dst**2 / (4. * rcf%L**2) + grd%bty(i,j) = 1. + E - sqrt(E*(E+2.)) + enddo + enddo + + grd%alx( 1,:) = grd%alx( 2,:) + grd%btx(grd%im,:) = grd%btx(grd%im-1,:) + grd%aly(:, 1) = grd%aly(:, 2) + grd%bty(:,grd%jm) = grd%bty(:,grd%jm-1) + +!--- +! Define extended grids + + grd%istp = int( rcf%L * rcf%efc / grd%dx(:,:) )+1 + grd%jstp = int( rcf%L * rcf%efc / grd%dy(:,:) )+1 + grd%imax = 0 + grd%jmax = 0 + + + do k = 1, grd%km + + grd%imx(k) = 0 + do j = 1, grd%jm + kk = grd%istp(1,j) + if( grd%msr(1,j,k).eq.1. ) kk = kk + 1 + grd%inx(1,j,k) = kk + do i = 2, grd%im + if( grd%msr(i,j,k).eq.0. .and. grd%msr(i-1,j,k).eq.1. ) then + kk = kk + grd%istp(i,j) + else if( grd%msr(i,j,k).eq.1. .and. grd%msr(i-1,j,k).eq.0. ) then + kk = kk + grd%istp(i,j) + 1 + else if( grd%msr(i,j,k).eq.1. ) then + kk = kk + 1 + endif + grd%inx(i,j,k) = kk + enddo + grd%imx(k) = max( grd%imx(k), kk+grd%istp(grd%im,j)) + enddo + grd%imax = max( grd%imax, grd%imx(k)) + + grd%jmx(k) = 0 + do i = 1, grd%im + kk = grd%jstp(i,1) + if( grd%msr(i,1,k).eq.1. ) kk = kk + 1 + grd%jnx(i,1,k) = kk + do j = 2, grd%jm + if( grd%msr(i,j,k).eq.0. .and. grd%msr(i,j-1,k).eq.1. ) then + kk = kk + grd%jstp(i,j) + else if( grd%msr(i,j,k).eq.1. .and. grd%msr(i,j-1,k).eq.0. ) then + kk = kk + grd%jstp(i,j) + 1 + else if( grd%msr(i,j,k).eq.1. ) then + kk = kk + 1 + endif + grd%jnx(i,j,k) = kk + enddo + grd%jmx(k) = max( grd%jmx(k), kk+grd%jstp(i,grd%jm)) + enddo + grd%jmax = max( grd%jmax, grd%jmx(k)) + + enddo + + + ALLOCATE( grd%aex(grd%jm,grd%imax,grd%km)) ; grd%aex(:,:,:) = 0.0 + ALLOCATE( grd%bex(grd%jm,grd%imax,grd%km)) ; grd%bex(:,:,:) = 0.0 + ALLOCATE( grd%aey(grd%im,grd%jmax,grd%km)) ; grd%aey(:,:,:) = 0.0 + ALLOCATE( grd%bey(grd%im,grd%jmax,grd%km)) ; grd%bey(:,:,:) = 0.0 + + + do k = 1, grd%km + + do j = 1, grd%jm + kk = grd%istp(1,j) + if( grd%msr(1,j,k).eq.1. ) then + kk = kk + 1 + grd%aex(j,1:kk,k) = grd%alx(1,j) + grd%bex(j,1:kk,k) = grd%btx(1,j) + endif + do i = 2, grd%im + if( grd%msr(i,j,k).eq.0. .and. grd%msr(i-1,j,k).eq.1. ) then + grd%aex(j,kk+1:kk+grd%istp(i,j),k) = grd%alx(i,j) + grd%bex(j,kk+1:kk+grd%istp(i,j),k) = grd%btx(i,j) + kk = kk + grd%istp(i,j) + else if( grd%msr(i,j,k).eq.1. .and. grd%msr(i-1,j,k).eq.0. ) then + grd%aex(j,kk+1:kk+grd%istp(i,j)+1,k) = grd%alx(i,j) + grd%bex(j,kk+1:kk+grd%istp(i,j)+1,k) = grd%btx(i,j) + kk = kk + grd%istp(i,j) + 1 + else if( grd%msr(i,j,k).eq.1. ) then + grd%aex(j,kk+1,k) = grd%alx(i,j) + grd%bex(j,kk+1,k) = grd%btx(i,j) + kk = kk + 1 + endif + enddo + enddo + + do i = 1, grd%im + kk = grd%jstp(i,1) + if( grd%msr(i,1,k).eq.1. ) then + kk = kk + 1 + grd%aey(i,1:kk,k) = grd%aly(i,1) + grd%bey(i,1:kk,k) = grd%bty(i,1) + endif + do j = 2, grd%jm + if( grd%msr(i,j,k).eq.0. .and. grd%msr(i,j-1,k).eq.1. ) then + grd%aey(i,kk+1:kk+grd%jstp(i,j),k) = grd%aly(i,j) + grd%bey(i,kk+1:kk+grd%jstp(i,j),k) = grd%bty(i,j) + kk = kk + grd%jstp(i,j) + else if( grd%msr(i,j,k).eq.1. .and. grd%msr(i,j-1,k).eq.0. ) then + grd%aey(i,kk+1:kk+grd%jstp(i,j)+1,k) = grd%aly(i,j) + grd%bey(i,kk+1:kk+grd%jstp(i,j)+1,k) = grd%bty(i,j) + kk = kk + grd%jstp(i,j) + 1 + else if( grd%msr(i,j,k).eq.1. ) then + grd%aey(i,kk+1,k) = grd%aly(i,j) + grd%bey(i,kk+1,k) = grd%bty(i,j) + kk = kk + 1 + endif + enddo + enddo + + enddo + + do k=1,grd%km + do j=1,grd%jm + do i=1,grd%im + if(grd%msr(i,j,k).eq.1.0)then + grd%fct(i,j,k) = 1.0 + else + grd%fct(i,j,k) = 0.0 + endif + enddo + enddo + enddo + + +! --- +! Vertical EOFs + + if(drv%biol.eq.1 .and. drv%bphy.eq.0)then + ros%kmt = grd%km * grd%nchl + else if(drv%biol.eq.1 .and. drv%bphy.eq.1)then + ros%kmt = grd%km * (2 + grd%nchl) + 1 + else + ros%kmt = grd%km * 2 + 1 + endif + + call rdeofs + + ALLOCATE ( grd%ro( grd%im, grd%jm, ros%neof)) ; grd%ro = 0.0 + ALLOCATE ( grd%ro_ad( grd%im, grd%jm, ros%neof)) ; grd%ro_ad = 0.0 + ALLOCATE ( Dump_vip ( grd%im, grd%jm, ros%neof)) ; Dump_vip = 0.0 + + write(*,*) 'rcfl allocation :', grd%jm, grd%imax, nthreads + ALLOCATE ( a_rcx(grd%jm,grd%imax,nthreads)) ; a_rcx = huge(a_rcx(1,1,1)) + ALLOCATE ( b_rcx(grd%jm,grd%imax,nthreads)) ; b_rcx = huge(b_rcx(1,1,1)) + ALLOCATE ( c_rcx(grd%jm,grd%imax,nthreads)) ; c_rcx = huge(c_rcx(1,1,1)) + + ALLOCATE ( a_rcy(grd%im,grd%jmax,nthreads)) ; a_rcy = huge(a_rcy(1,1,1)) + ALLOCATE ( b_rcy(grd%im,grd%jmax,nthreads)) ; b_rcy = huge(b_rcy(1,1,1)) + ALLOCATE ( c_rcy(grd%im,grd%jmax,nthreads)) ; c_rcy = huge(c_rcy(1,1,1)) + + + ALLOCATE ( alp_rcx(grd%jm,grd%imax,nthreads)) ; alp_rcx = huge(alp_rcx(1,1,1)) + ALLOCATE ( bta_rcx(grd%jm,grd%imax,nthreads)) ; bta_rcx = huge(bta_rcx(1,1,1)) + + ALLOCATE ( alp_rcy(grd%im,grd%jmax,nthreads)) ; alp_rcy = huge(alp_rcy(1,1,1)) + ALLOCATE ( bta_rcy(grd%im,grd%jmax,nthreads)) ; bta_rcy = huge(bta_rcy(1,1,1)) + +end subroutine def_cov diff --git a/def_grd.f90 b/def_grd.f90 new file mode 100644 index 0000000..f336bf4 --- /dev/null +++ b/def_grd.f90 @@ -0,0 +1,120 @@ +subroutine def_grd + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Define the grid ! +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + + use set_knd + use drv_str + use grd_str + + implicit none + + INTEGER(I4) :: i, j, k + INTEGER :: indSupWP +! --- +! Define grid + grd%grd_mod = drv%grid (drv%ktr) + grd%read_grd = drv%read_grd (drv%ktr) + +!Read grid definition + call rdgrd + grd%dxdy(:,:) = grd%dy(:,:) * grd%dx(:,:) + + grd%dlt = (grd%lat(1,2) - grd%lat(1,1)) + grd%dln = (grd%lon(2,1) - grd%lon(1,1)) + +! Define grid for horizontal covariances + if( drv%mask(drv%ktr).eq.1)then + grd%msr(:,:,:) = 1.0 + else if( drv%mask(drv%ktr).eq.2)then + do k=1,grd%km + grd%msr(:,:,k) = grd%msk(:,:,1) + enddo + + else if( drv%mask(drv%ktr).eq.3)then +do i=1,grd%im +do j=1,grd%jm +do k=1,grd%km +grd%msr(i,j,k) = grd%msk(i,j,k) +enddo +enddo +enddo +! grd%msr(:,:,:) = grd%msk(:,:,:) + else + write(drv%dia,*)'Wrong mask for horizontal covariances ', & + drv%mask(drv%ktr) + !stop + call f_exit(21) + endif + grd%adxdy = sum(grd%dxdy) / (grd%im * grd%jm) + + grd%dxdy(:,:) = sqrt(grd%dxdy(:,:)) + grd%adxdy = sqrt(grd%adxdy) + + grd%nps = grd%im*grd%jm*grd%km + + do k=1,grd%km + grd%ums(1:grd%im-1,1:grd%jm,k) = & + grd%msk(1:grd%im-1,1:grd%jm,k) * grd%msk(2:grd%im,1:grd%jm,k) + grd%vms(1:grd%im,1:grd%jm-1,k) = & + grd%msk(1:grd%im,1:grd%jm-1,k) * grd%msk(1:grd%im,2:grd%jm,k) + enddo + + do j= 1,grd%jm + do i= 1,grd%im + grd%f(i,j) = 0.00014584 * & + sin((grd%lat(1,1)+(j-1.+0.5)*(grd%lat(2,1)-grd%lat(1,1)))*3.141592654/180.) + enddo + enddo + + +nSurfaceWaterPoints = 0 +do i=1,grd%im +do j=1,grd%jm + if (grd%msk(i,j,1).eq.1) nSurfaceWaterPoints = nSurfaceWaterPoints+1 +enddo +enddo + + +ALLOCATE (SurfaceWaterpoints(2,nSurfaceWaterpoints)) + +write(*,*) 'nSurfaceWaterpoints = ', nSurfaceWaterpoints + +indSupWP=0 +do i=1,grd%im +do j=1,grd%jm + if (grd%msk(i,j,1).eq.1) then + indSupWP = indSupWP+1 + SurfaceWaterPoints(1,indSupWP) = i + SurfaceWaterPoints(2,indSupWP) = j + endif +enddo +enddo + +end subroutine def_grd diff --git a/def_nml.f90 b/def_nml.f90 new file mode 100644 index 0000000..b6e495a --- /dev/null +++ b/def_nml.f90 @@ -0,0 +1,247 @@ +subroutine def_nml + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Define analysis parameters from namelists ! +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + use set_knd + use drv_str + use grd_str + use bmd_str + use obs_str + use eof_str + use cns_str + use ctl_str + + implicit none + + INTEGER(i4), PARAMETER :: ngrids = 3 + + CHARACTER(LEN=12) :: flag_a + INTEGER(i4) :: sdat_f, shou_f, lhou_f + LOGICAL :: read_eof + INTEGER(i4) :: neof, nreg, rcf_ntr, ntr + INTEGER(i4) :: ctl_m + INTEGER(i4) :: obs_sla, obs_arg, obs_xbt, obs_gld, obs_tra, obs_trd, obs_gvl, obs_chl + INTEGER(i4) :: obs_vdr, bmd_ncnt + INTEGER(i4) :: biol, bphy, nchl + REAL(r8) :: sla_dep, rcf_L, ctl_tol, ctl_per, bmd_fc1, bmd_fc2, rcf_efc, chl_dep + REAL(r8) :: bmd_dt, bmd_ndy, bmd_ady, bmd_alp, bmd_ovr, bmd_resem + INTEGER(i4) :: grid (ngrids) + REAL(r8) :: ratio(ngrids) + INTEGER(i4) :: mask (ngrids) + INTEGER(i4) :: barmd(ngrids) + INTEGER(i4) :: divda(ngrids) + INTEGER(i4) :: divdi(ngrids) + LOGICAL :: read_grd(ngrids) + + + NAMELIST /runlst/ flag_a, sdat_f, shou_f, lhou_f + NAMELIST /obslst/ obs_sla, obs_arg, obs_xbt, obs_gld, obs_tra, & + obs_trd, obs_vdr, obs_gvl, obs_chl + NAMELIST /grdlst/ ntr, grid, read_grd, ratio, mask, barmd, divda, divdi + NAMELIST /ctllst/ ctl_m, ctl_tol, ctl_per + NAMELIST /covlst/ neof, nreg, read_eof, rcf_ntr, rcf_L, rcf_efc + NAMELIST /slalst/ sla_dep + NAMELIST /bmdlst/ bmd_dt, bmd_ndy, bmd_ady, bmd_alp, bmd_fc1, bmd_fc2, & + bmd_ovr, bmd_resem, bmd_ncnt + NAMELIST /biolst/ biol, bphy, nchl, chl_dep + + +! ------------------------------------------------------------------- +! Open a formatted file for the diagnostics +! --- + + drv%dia = 12 + + open ( drv%dia, file='OceanVar.diagnostics', form='formatted' ) + +!--------------------------------------------------------------------- +! Open the namelist +! --- + + open(11,file='var_3d_nml',form='formatted') + + write(drv%dia,*) '------------------------------------------------------------' + write(drv%dia,*) ' ' + write(drv%dia,*) ' NAMELISTS: ' + write(drv%dia,*) ' ' + +! --- + read(11,runlst) + + write(drv%dia,*) '------------------------------------------------------------' + write(drv%dia,*) ' RUN NAMELIST INPUT: ' + write(drv%dia,*) ' Flag for the analysis: flag_a = ', flag_a + write(drv%dia,*) ' Starting day of the forecast: sdat_f = ', sdat_f + write(drv%dia,*) ' Starting hour of the forecast: shou_f = ', shou_f + write(drv%dia,*) ' Lenght of the forecast: lhou_f = ', lhou_f + + drv%flag = flag_a + drv%sdat = sdat_f + drv%shou = shou_f + drv%lhou = lhou_f + +! --- + read(11,obslst) + + write(drv%dia,*) '------------------------------------------------------------' + write(drv%dia,*) ' OBSERVATIONS NAMELIST INPUT: ' + write(drv%dia,*) ' Use SLA observations: obs_sla = ', obs_sla + write(drv%dia,*) ' Use ARGO observations: obs_arg = ', obs_arg + write(drv%dia,*) ' Use XBT observations: obs_xbt = ', obs_xbt + write(drv%dia,*) ' Use glider observations: obs_gld = ', obs_gld + write(drv%dia,*) ' Use Argo trajectory observations: obs_tra = ', obs_tra + write(drv%dia,*) ' Use drifter trajectory observations: obs_trd = ', obs_trd + write(drv%dia,*) ' Use drifter observations of velocity: obs_vdr = ', obs_vdr + write(drv%dia,*) ' Use glider observations of velocity: obs_gvl = ', obs_gvl + write(drv%dia,*) ' Use Chlorophyll: obs_chl = ', obs_chl + + obs%sla = obs_sla + obs%arg = obs_arg + obs%xbt = obs_xbt + obs%gld = obs_gld + obs%tra = obs_tra + obs%trd = obs_trd + obs%vdr = obs_vdr + obs%gvl = obs_gvl + obs%chl = obs_chl + +! --- + read(11,grdlst) + + write(drv%dia,*) '------------------------------------------------------------' + write(drv%dia,*) ' GRID NAMELIST INPUT: ' + write(drv%dia,*) ' Multigrid iterrations: ntr = ', ntr + write(drv%dia,*) ' Grids: grid = ', grid (1:ntr) + write(drv%dia,*) ' Read grids from a file: read_grd = ', read_grd + write(drv%dia,*) ' Ratio: ratio = ', ratio(1:ntr) + write(drv%dia,*) ' Masks: mask = ', mask(1:ntr) + write(drv%dia,*) ' Run barotropic model: barmd = ', barmd(1:ntr) + write(drv%dia,*) ' Divergence damping in analysis: divda = ', divda(1:ntr) + write(drv%dia,*) ' Divergence damping in initialisation: divdi = ', divdi(1:ntr) + + drv%ntr = ntr + ALLOCATE( drv%grid (drv%ntr)) ; drv%grid (1:drv%ntr) = grid (1:drv%ntr) + ALLOCATE( drv%read_grd (drv%ntr)) ; drv%read_grd(1:drv%ntr) = read_grd(1:drv%ntr) + ALLOCATE( drv%ratco(drv%ntr)) ; drv%ratco(1:drv%ntr) = ratio(1:drv%ntr) + ALLOCATE( drv%ratio(drv%ntr)) ; drv%ratio = huge(drv%ratio(1)) + ALLOCATE( drv%mask (drv%ntr)) ; drv%mask (1:drv%ntr) = mask (1:drv%ntr) + ALLOCATE( drv%bmd(drv%ntr)) ; drv%bmd (1:drv%ntr) = barmd(1:drv%ntr) + ALLOCATE( drv%dda(drv%ntr)) ; drv%dda (1:drv%ntr) = divda(1:drv%ntr) + ALLOCATE( drv%ddi(drv%ntr)) ; drv%ddi (1:drv%ntr) = divdi(1:drv%ntr) + + drv%ratio( 1) = 1.0 + if(drv%ntr.gt.1) drv%ratio(2:drv%ntr) = drv%ratco(1:drv%ntr-1) / drv%ratco(2:drv%ntr) + +! --- + read(11,ctllst) + + write(drv%dia,*) '------------------------------------------------------------' + write(drv%dia,*) ' MINIMIZER NAMELIST INPUT: ' + write(drv%dia,*) ' Number of saved vectors: ctl_m = ', ctl_m + write(drv%dia,*) ' Minimum gradient of J: ctl_tol = ', ctl_tol + write(drv%dia,*) ' Percentage of initial gradient: ctl_per = ', ctl_per + + ctl%m = ctl_m + ctl%pgtol = ctl_tol + ctl%pgper = ctl_per + +! --- + read(11,covlst) + + write(drv%dia,*) '------------------------------------------------------------' + write(drv%dia,*) ' COVARIANCE NAMELIST INPUT: ' + write(drv%dia,*) ' Number of EOFs: neof = ', neof + write(drv%dia,*) ' Number of regions: nreg = ', nreg + write(drv%dia,*) ' Read EOFs from a file: read_eof = ', read_eof + write(drv%dia,*) ' Half number of iterations: rcf_ntr = ', rcf_ntr + write(drv%dia,*) ' Horizontal correlation radius: rcf_L = ', rcf_L + write(drv%dia,*) ' Extension factor for coastlines: rcf_efc = ', rcf_efc + + ros%neof = neof + ros%nreg = nreg + ros%read_eof = read_eof + rcf%ntr = rcf_ntr + rcf%L = rcf_L + rcf%efc = rcf_efc + +! --- + read(11,slalst) + + write(drv%dia,*) '------------------------------------------------------------' + write(drv%dia,*) ' SLA NAMELIST INPUT: ' + write(drv%dia,*) ' Minimum depth for observations: sla_dep = ', sla_dep + + sla%dep = sla_dep + +! --- + read(11,bmdlst) + + write(drv%dia,*) '------------------------------------------------------------' + write(drv%dia,*) ' BAROTROPIC MODEL NAMELIST INPUT: ' + write(drv%dia,*) ' Time step: bmd_dt = ', bmd_dt + write(drv%dia,*) ' Simulation days: bmd_ndy = ', bmd_ndy + write(drv%dia,*) ' Averaged days: bmd_ady = ', bmd_ady + write(drv%dia,*) ' Implicit weight: bmd_alp = ', bmd_alp + write(drv%dia,*) ' Friction intensity: bmd_fc1 = ', bmd_fc1 + write(drv%dia,*) ' Friction intensity: bmd_fc2 = ', bmd_fc2 + write(drv%dia,*) ' Over-relaxation: bmd_ovr = ', bmd_ovr + write(drv%dia,*) ' Minimum residual: bmd_resem = ', bmd_resem + write(drv%dia,*) ' Maximum iterations bmd_ncnt = ', bmd_ncnt + + bmd%dt = bmd_dt !7200. !1800. + bmd%ndy = bmd_ndy ! 3. + bmd%ady = bmd_ady ! 1. + bmd%alp1 = bmd_alp !1.0 + bmd%fc1 = bmd_fc1 + bmd%fc2 = bmd_fc2 + bmd%ovr = bmd_ovr !1.9 + bmd%resem = bmd_resem !5.e-2 + bmd%ncnt = bmd_ncnt !201 + + write(drv%dia,*) '------------------------------------------------------------' + +! --- + read(11,biolst) + + write(drv%dia,*) '------------------------------------------------------------' + write(drv%dia,*) ' BIOLOGY NAMELIST INPUT: ' + write(drv%dia,*) ' Biological assimilation biol = ', biol + write(drv%dia,*) ' Biological+physical assimilation bphy = ', bphy + write(drv%dia,*) ' Number of phytoplankton species nchl = ', nchl + write(drv%dia,*) ' Minimum depth for chlorophyll chl_dep = ', chl_dep + + drv%biol = biol + drv%bphy = bphy + grd%nchl = nchl + chl%dep = chl_dep + + + +close(11) +end subroutine def_nml diff --git a/drv_str.f90 b/drv_str.f90 new file mode 100644 index 0000000..28356c0 --- /dev/null +++ b/drv_str.f90 @@ -0,0 +1,68 @@ +MODULE drv_str + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Structure for the driver of the outer loop ! +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + use set_knd + +implicit none + +public + + TYPE drv_t + + CHARACTER(LEN=12) :: flag ! Flag for the analysis + INTEGER(I4) :: sdat ! Starting date of the forecast + INTEGER(I4) :: shou ! Starting hour of the forecast + INTEGER(I4) :: lhou ! Length of the forecast + INTEGER(i4) :: dia ! No. of diagnostic output file + INTEGER(i4) :: ntr ! No. of outer iterations + INTEGER(i4) :: ktr ! Outer iteration + INTEGER(i4) :: im ! Dimension of the coarse grid + INTEGER(i4) :: jm ! Dimension of the coarse grid + INTEGER(i4), POINTER :: grid(:) ! grid number for the current iterration + LOGICAL , POINTER :: read_grd(:) ! Flag to read the grid + REAL(r8), POINTER :: ratco(:) ! Ratio between model grid and the current grid + REAL(r8), POINTER :: ratio(:) ! Ratio between successive grids + INTEGER(i4), POINTER :: mask(:) ! Mask used for horizontal covariances + INTEGER(i4), POINTER :: bmd(:) ! 1 - run barotropic model, else - do not run + INTEGER(i4), POINTER :: dda(:) ! 1 - divergence damping in analysis, else no filter + INTEGER(i4), POINTER :: ddi(:) ! 1 - divergence damping in initialisation, else no filter + REAL(r8) :: f_ci ! Inital cost function + REAL(r8), POINTER :: ro(:,:,:) ! Vector v + REAL(r8) :: f_c ! Cost function + REAL(r8), POINTER :: ro_ad(:,:,:) ! Observational part of the cost function gradient + REAL(r8), POINTER :: msk(:,:) ! Mask of the old grid + INTEGER(i4) :: biol ! Flag for the assimilation of biological parameters + INTEGER(i4) :: bphy ! Flag for the assimilation of biological+physical parameters + + END TYPE drv_t + + TYPE (drv_t) :: drv + +END MODULE drv_str diff --git a/eof_str.f90 b/eof_str.f90 new file mode 100644 index 0000000..8c7747e --- /dev/null +++ b/eof_str.f90 @@ -0,0 +1,61 @@ +MODULE eof_str + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Structure of EOFs ! +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + use set_knd + +implicit none + +public + + TYPE eof_t + + LOGICAL :: read_eof ! Read EOFs from file + INTEGER(i4) :: neof ! No. of EOFs + INTEGER(i4) :: nreg ! No. of regions + INTEGER(i4) :: kmt ! No. of levels of EOFs + REAL(r8), POINTER :: evcr(:,:,:) ! Eigenvectors on regions + REAL(r8), POINTER :: evar(:,:) ! Eigenvalues on regions + REAL(r8), POINTER :: corr(:,:,:) ! Corelations on regions +#ifdef opt_huge_memory + REAL(r8), POINTER :: evc(:,:,:,:) ! Eigenvectors + REAL(r8), POINTER :: eva(:,:,:) ! Eigenvalues + REAL(r8), POINTER :: cor(:,:,:,:) ! Corelation matrix +#else + REAL(r8), POINTER :: evc(:,:,:) ! Eigenvectors + REAL(r8), POINTER :: eva(:,:) ! Eigenvalues + REAL(r8), POINTER :: cor(:,:,:) ! Corelation matrix +#endif + + + END TYPE eof_t + + TYPE (eof_t) :: ros + +END MODULE eof_str diff --git a/filename_mod.f90 b/filename_mod.f90 new file mode 100644 index 0000000..e9da2e3 --- /dev/null +++ b/filename_mod.f90 @@ -0,0 +1,35 @@ +MODULE FILENAMES +implicit none + +PUBLIC +character (LEN=1024) :: EOF_FILE != 'eofs.nc' +character (LEN=1024) :: MISFIT_FILE != 'chl_mis.nc' +character (LEN=1024) :: CORR_FILE != 'corr.nc' +character (LEN=1024) :: EIV_FILE != 'eiv.nc' +character (LEN=1024) :: OBS_FILE != 'obs_1.dat' +character (LEN=1024) :: GRID_FILE != 'grid1.nc' + + + + +CONTAINS +! +! +SUBROUTINE SETFILENAMES +! !VAR_FILE='DA_static_data/MISFIT/VAR2D/var2D.05.nc' +! + EOF_FILE = 'eofs.nc' +MISFIT_FILE = 'chl_mis.nc' + CORR_FILE = 'corr.nc' + EIV_FILE = 'eiv.nc' + OBS_FILE = 'obs_1.dat' ! 'obs_'//fgrd//'.dat' + GRID_FILE = 'grid1.nc'! 'grid'//cgrd//'.nc' + +END SUBROUTINE SETFILENAMES + + + + + + +END MODULE FILENAMES diff --git a/get_obs.f90 b/get_obs.f90 new file mode 100644 index 0000000..e41637d --- /dev/null +++ b/get_obs.f90 @@ -0,0 +1,76 @@ +subroutine get_obs + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Load observations ! +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + + use set_knd + use obs_str + + implicit none + +#ifdef __FISICA +! ---- +! Load SLA observations + call get_obs_sla + +! ---- +! Load ARGO observations + call get_obs_arg + +! ---- +! Load XBT observations + call get_obs_xbt + +! ---- +! Load glider observations + call get_obs_gld + +! ---- +! Load Argo trajectory observations + call get_obs_tra + +! ---- +! Load trajectory observations of surface drifters + call get_obs_trd + +! ---- +! Load observations of velocity by drifters + call get_obs_vdr + +! ---- +! Load observations of velocity by drifters + call get_obs_gvl + +#endif + +! ---- +! Load observations of chlorophyll + call get_obs_chl + +end subroutine get_obs diff --git a/get_obs_chl.f90 b/get_obs_chl.f90 new file mode 100644 index 0000000..1a15429 --- /dev/null +++ b/get_obs_chl.f90 @@ -0,0 +1,274 @@ +subroutine get_obs_chl + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Load Chlorophyll observations ! +! ! +!----------------------------------------------------------------------- + + use set_knd + use drv_str + use grd_str + use obs_str + use netcdf + use filenames + + implicit none + + INTEGER(i4) :: j,k, kk + INTEGER(i4) :: i + REAL(r8) :: zbo, zbn + REAL(r4), ALLOCATABLE :: chl_mis(:,:),chl_err(:,:) + INTEGER(i4) :: stat, ncid, idvar + + chl%no = 0 + chl%nc = 0 + + + stat = nf90_open(trim(MISFIT_FILE), NF90_NOWRITE, ncid) + + if(stat.ne.0)then + chl%no = 0 + return + endif + + chl%no = grd%im*grd%jm + + +! --- +! Level corresponding to the minimum depth and maximum light propagation + chl%kdp=grd%km + do k=grd%km, 1, -1 + if(grd%dep(k).ge.chl%dep) chl%kdp = k + enddo + + +! --- +! Allocate memory for observations + + + ALLOCATE ( chl_mis(grd%im,grd%jm) ) ; chl_mis = huge(chl_mis(1,1)) + ALLOCATE ( chl_err(grd%im,grd%jm) ) ; chl_err = huge(chl_err(1,1)) + ALLOCATE ( chl%flg(chl%no)) ; chl%flg = huge(chl%flg(1)) + ALLOCATE ( chl%flc(chl%no)) ; chl%flc = huge(chl%flc(1)) + ALLOCATE ( chl%inc(chl%no)) ; chl%inc = huge(chl%inc(1)) + ALLOCATE ( chl%err(chl%no)) ; chl%err = huge(chl%err(1)) + ALLOCATE ( chl%res(chl%no)) ; chl%res = huge(chl%res(1)) + ALLOCATE ( chl%b_a(chl%no)) ; chl%b_a = huge( chl%b_a(1)) + ALLOCATE ( chl%ib(chl%no)) ; chl%ib = huge(chl%ib(1)) + ALLOCATE ( chl%jb(chl%no)) ; chl%jb = huge(chl%jb(1)) + ALLOCATE ( chl%pb(chl%no)) ; chl%pb = huge(chl%pb(1)) + ALLOCATE ( chl%qb(chl%no)) ; chl%qb = huge(chl%qb(1)) + ALLOCATE ( chl%pq1(chl%no)) ;chl%pq1 = huge(chl%pq1(1)) + ALLOCATE ( chl%pq2(chl%no)) ; chl%pq2 = huge(chl%pq2(1)) + ALLOCATE ( chl%pq3(chl%no)) ; chl%pq3 = huge(chl%pq3(1)) + ALLOCATE ( chl%pq4(chl%no)) ; chl%pq4 = huge(chl%pq4(1)) + ALLOCATE ( chl%dpt(chl%no)) ; chl%dpt = huge(chl%dpt(1)) + ALLOCATE ( chl%kb(chl%no)) ; chl%kb = huge(chl%kb(1)); + ALLOCATE ( chl%dzr(grd%km,chl%no)) ; chl%dzr=huge(chl%dzr(1,1)) + + + + + stat = nf90_inq_varid (ncid, 'misfchl', idvar) + if(stat .ne. 0) then + call f_exit_message(10, 'var misfchl not found') + endif + + stat = nf90_get_var (ncid, idvar, chl_mis) + if(stat .ne. 0) then + call f_exit_message(10, 'cannot read var misfchl') + endif + + stat = nf90_inq_varid (ncid, 'errchl', idvar) + if(stat .ne. 0) then + call f_exit_message(10, 'var errchl not found') + endif + + stat = nf90_get_var (ncid, idvar, chl_err) + if(stat .ne. 0) then + call f_exit_message(10, 'cannot read var errchl') + endif + + do k=1,chl%no + j = (k-1)/grd%im + 1 + i = k - (j-1)*grd%im + chl%res(k) = chl_mis(i,j) + chl%err(k) = chl_err(i,j) + enddo + + + DEALLOCATE( chl_mis ) + + stat = nf90_close (ncid) + +! chl%err(:) = 0.3 + + chl%kb(:) = 1 + +! --- +! Initialise quality flag + do k=1,chl%no + j = (k-1)/grd%im + 1 + i = k - (j-1)*grd%im + if(grd%msk(i,j,chl%kdp).eq.1. )then + chl%flg(k) = 1 + else + chl%flg(k) = 0 + endif + enddo + + if(obs%chl.eq.0) chl%flg(:) = -1 + +! residual check + do k=1,chl%no + if(abs(chl%res(k)).gt.10.0) chl%flg(k) = 0 + enddo + +! --- +! Vertical intgration parameters + do k = 1,chl%no + + if(chl%flg(k).eq.1)then + zbn = grd%dep(1)*2.0 + chl%dzr(1,k) = zbn + zbo = zbn + do kk = 2,chl%kb(k) + zbn = (grd%dep(kk)-zbo)*2.0 + chl%dzr(kk,k) = zbn + zbo= zbo + zbn + enddo + chl%dzr(:,k) = chl%dzr(:,k) / zbo + endif + + enddo + + + chl%flc(:) = chl%flg(:) + +! --- +! Count good observations + chl%nc = 0 + do k=1,chl%no + if(chl%flc(k).eq.1)then + chl%nc = chl%nc + 1 + endif + enddo + + + +end subroutine get_obs_chl + +subroutine int_par_chl + +!----------------------------------------------------------------------- +! ! +! Get interpolation parameters for a grid ! +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + use set_knd + use drv_str + use grd_str + use obs_str + + implicit none + + integer(i4) :: k + integer(i4) :: i1, kk, j1 + real(r8) :: p1, q1 + real(r8) :: div_x, div_y + + write(drv%dia,*) 'Number of CHL observations: >>>>>>>>>>>>>',chl%nc + + if(chl%nc.gt.0) then + + +! --- +! Interpolation parameters + do kk = 1,chl%no + j1 = (kk-1)/grd%im + 1 + i1 = kk - (j1-1)*grd%im + q1 = 0.0 + p1 = 0.0 + chl%ib(kk) = i1 + chl%jb(kk) = j1 + chl%pb(kk) = p1 + chl%qb(kk) = q1 + enddo + + +! --- +! Horizontal interpolation parameters for each masked grid + do k = 1,chl%no + if(chl%flc(k) .eq. 1) then + + i1=chl%ib(k) + p1=chl%pb(k) + j1=chl%jb(k) + q1=chl%qb(k) + + div_y = (1.-q1) * max(grd%msk(i1,j1 ,1),grd%msk(i1+1,j1 ,1)) & + + q1 * max(grd%msk(i1,j1+1,1),grd%msk(i1+1,j1+1,1)) + div_x = (1.-p1) * grd%msk(i1 ,j1,1) + p1 * grd%msk(i1+1,j1,1) + chl%pq1(k) = grd%msk(i1,j1,1) & + * max(grd%msk(i1,j1,1),grd%msk(i1+1,j1,1)) & + * (1.-p1) * (1.-q1) & + /( div_x * div_y + 1.e-16 ) + chl%pq2(k) = grd%msk(i1+1,j1,1) & + * max(grd%msk(i1,j1,1),grd%msk(i1+1,j1,1)) & + * p1 * (1.-q1) & + /( div_x * div_y + 1.e-16 ) + div_x = (1.-p1) * grd%msk(i1 ,j1+1,1) + p1 * grd%msk(i1+1,j1+1,1) + chl%pq3(k) = grd%msk(i1,j1+1,1) & + * max(grd%msk(i1,j1+1,1),grd%msk(i1+1,j1+1,1)) & + * (1.-p1) * q1 & + /( div_x * div_y + 1.e-16 ) + chl%pq4(k) = grd%msk(i1+1,j1+1,1) & + * max(grd%msk(i1,j1+1,1),grd%msk(i1+1,j1+1,1)) & + * p1 * q1 & + /( div_x * div_y + 1.e-16 ) + + endif + enddo + +! --- +! Count good observations + chl%nc = 0 + do k=1,chl%no + if(chl%flc(k).eq.1)then + chl%nc = chl%nc + 1 + endif + enddo + + print*,'Good chl observations: ',chl%nc + + + endif + + + + +end subroutine int_par_chl diff --git a/grd_str.f90 b/grd_str.f90 new file mode 100644 index 0000000..9a4b59a --- /dev/null +++ b/grd_str.f90 @@ -0,0 +1,136 @@ +MODULE grd_str + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Structure of the grid ! +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + use set_knd + +implicit none + +public + + TYPE grid_t + + INTEGER(i4) :: grd_mod ! Grid model + LOGICAL :: read_grd ! Read the grid from a file + + INTEGER(i4) :: im ! No. points in x direction + INTEGER(i4) :: jm ! No. points in y direction + INTEGER(i4) :: km ! No. points in z direction + INTEGER(i4) :: nps ! No. of ocean points + + REAL(r8) :: dln ! Resolution in the x direction + REAL(r8) :: dlt ! Resolution in the y direction + + REAL(r8), POINTER :: ro(:,:,:) ! Reduced order control vector + INTEGER(i4), POINTER :: reg(:,:) ! Mask for EOF regions + REAL(r8), POINTER :: msk(:,:,:) ! Sea-Land mask for scalar points + REAL(r8), POINTER :: ums(:,:,:) ! Sea-Land mask for u points + REAL(r8), POINTER :: vms(:,:,:) ! Sea-Land mask for v points + REAL(r8), POINTER :: hgt(:,:) ! Topography + REAL(r8), POINTER :: f(:,:) ! Coriolis term + + REAL(r8), POINTER :: tem(:,:,:) ! Temperature increment + REAL(r8), POINTER :: sal(:,:,:) ! Salinity increment + REAL(r8), POINTER :: uvl(:,:,:) ! u componnet of velocity increment + REAL(r8), POINTER :: vvl(:,:,:) ! v componnet of velocity increment + REAL(r8), POINTER :: eta(:,:) ! Sea level increment + + REAL(r8), POINTER :: temb(:,:,:) ! Temperature background + REAL(r8), POINTER :: salb(:,:,:) ! Salinity background + REAL(r8), POINTER :: uvlb(:,:,:) ! u componnet of velocity background + REAL(r8), POINTER :: vvlb(:,:,:) ! v componnet of velocity background + REAL(r8), POINTER :: etab(:,:) ! Sea level background + + REAL(r8), POINTER :: mdt(:,:) ! Mean dynamic topography + REAL(r8), POINTER :: sla(:,:) ! Sea level anomaly + + REAL(r8), POINTER :: ro_ad(:,:,:) ! Reduced order control vector adjoint + REAL(r8), POINTER :: tem_ad(:,:,:) ! Temperature adjoint + REAL(r8), POINTER :: sal_ad(:,:,:) ! Salinity adjoint + REAL(r8), POINTER :: uvl_ad(:,:,:) ! u componnet of velocity adjoint + REAL(r8), POINTER :: vvl_ad(:,:,:) ! v componnet of velocity adjoint + REAL(r8), POINTER :: eta_ad(:,:) ! Sea level adjoint + + REAL(r8), POINTER :: dns(:,:,:) ! density + REAL(r8), POINTER :: b_x(:,:,:) ! bouyancy force + REAL(r8), POINTER :: b_y(:,:,:) ! bouyancy force + REAL(r8), POINTER :: bx(:,:) ! bouyancy force integral + REAL(r8), POINTER :: by(:,:) ! bouyancy force integral + + INTEGER(i4) :: nchl ! No. of phytoplankton species + REAL(r8), POINTER :: chl(:,:,:,:) ! chlorophyll + REAL(r8), POINTER :: chl_ad(:,:,:,:) ! chlorophyll adjoint variable + + REAL(r8), POINTER :: lon(:,:) ! Longitude + REAL(r8), POINTER :: lat(:,:) ! Latitude + REAL(r8), POINTER :: dep(:) ! Depth + + REAL(r8), POINTER :: hvst(:,:,:) ! Horizontal diff. coef. for temperature + REAL(r8), POINTER :: hvss(:,:,:) ! Horizontal diff. coef. for salinity + REAL(r8), POINTER :: hvsp(:,:,:) ! Horizontal diff. coef. for stream function + REAL(r8), POINTER :: vvst(:,:,:) ! Vertical diff. coef. for temperature + REAL(r8), POINTER :: vvss(:,:,:) ! Vertical diff. coef. for salinity + REAL(r8), POINTER :: vvsp(:,:,:) ! Vertical diff. coef. for stream function + REAL(r8), POINTER :: dx(:,:) ! dx + REAL(r8), POINTER :: dy(:,:) ! dy + REAL(r8), POINTER :: dz(:) ! dz + REAL(r8), POINTER :: dxdy(:,:) ! dx*dy + REAL(r8) :: adxdy ! Mean dx*dy + + + REAL(r8), POINTER :: alx(:,:) ! Coefficient for the positive direction of the recursive filter + REAL(r8), POINTER :: aly(:,:) ! Coefficient for the positive direction of the recursive filter + REAL(r8), POINTER :: btx(:,:) ! Coefficient for the negative direction of the recursive filter + REAL(r8), POINTER :: bty(:,:) ! Coefficient for the negative direction of the recursive filter + REAL(r8), POINTER :: scx(:,:) ! Scaling factor for x direction + REAL(r8), POINTER :: scy(:,:) ! Scaling factor for y direction + REAL(r8), POINTER :: msr(:,:,:) ! Sea-land mask used in the recursive filter + INTEGER(i4) :: imax ! Maximum number of extended points + INTEGER(i4) :: jmax ! Maximum number of extended points + INTEGER(i4), POINTER :: imx(:) ! Max. no. of extended pnts at each level + INTEGER(i4), POINTER :: jmx(:) ! Max. no. of extended pnts at each level + INTEGER(i4), POINTER :: istp(:,:) ! Extended points + INTEGER(i4), POINTER :: jstp(:,:) ! Extended points + INTEGER(i4), POINTER :: inx(:,:,:) ! Pointer for extended grid + INTEGER(i4), POINTER :: jnx(:,:,:) ! Pointer for extended grid + REAL(r8), POINTER :: fct(:,:,:) ! Normalisation factor + REAL(r8), POINTER :: aex(:,:,:) ! Alpha x direction on extended grid + REAL(r8), POINTER :: aey(:,:,:) ! Alpha y direction on extended grid + REAL(r8), POINTER :: bex(:,:,:) ! Beta x direction on extended grid + REAL(r8), POINTER :: bey(:,:,:) ! Beta y direction on extended grid + + + END TYPE grid_t + + TYPE (grid_t) :: grd + INTEGER(i4), ALLOCATABLE, DIMENSION(:,:) :: SurfaceWaterpoints + INTEGER(i4) :: nSurfaceWaterPoints + REAL(r4), ALLOCATABLE, DIMENSION(:,:,:) :: Dump_chl, Dump_vip + REAL(r4), ALLOCATABLE, DIMENSION(:,:) :: Dump_msk +END MODULE grd_str diff --git a/ini_bmd.f90 b/ini_bmd.f90 new file mode 100644 index 0000000..88275f2 --- /dev/null +++ b/ini_bmd.f90 @@ -0,0 +1,173 @@ +subroutine ini_bmd + +!--------------------------------------------------------------------------- +! ! +! Copyright 2007 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Initialise the barotropic model ! +! ! +! Version 1: S.Dobricic 2007 ! +!----------------------------------------------------------------------- + + + use set_knd + use drv_str + use grd_str + use bmd_str + + implicit none + + INTEGER(i4) :: i, j + + bmd%g = 9.81 + bmd%nstp = int( 24. * 3600. / bmd%dt ) + bmd%nstps = int( bmd%ndy * bmd%nstp ) + bmd%nstpa = int( bmd%ady * bmd%nstp ) + bmd%alp2 = 1.0 - bmd%alp1 + + + bmd%df1 = bmd%fc1 * grd%adxdy**2 + bmd%df2 = bmd%fc2 * grd%adxdy**2 + + ALLOCATE ( bmd%itr(bmd%nstps) ) ; bmd%itr = huge(bmd%itr(1)) + ALLOCATE ( bmd%mst(grd%im,grd%jm)); bmd%mst = huge(bmd%mst(1,1)) + ALLOCATE ( bmd%msu(grd%im,grd%jm)); bmd%msu = huge(bmd%msu(1,1)) + ALLOCATE ( bmd%msv(grd%im,grd%jm)); bmd%msv = huge(bmd%msv(1,1)) + ALLOCATE ( bmd%hgt(grd%im,grd%jm)); bmd%hgt = huge(bmd%hgt(1,1)) + ALLOCATE ( bmd%hgu(grd%im,grd%jm)); bmd%hgu = huge(bmd%hgu(1,1)) + ALLOCATE ( bmd%hgv(grd%im,grd%jm)); bmd%hgv = huge(bmd%hgv(1,1)) + ALLOCATE ( bmd%dxu(grd%im,grd%jm)); bmd%dxu = huge(bmd%dxu(1,1)) + ALLOCATE ( bmd%dxv(grd%im,grd%jm)); bmd%dxv = huge(bmd%dxv(1,1)) + ALLOCATE ( bmd%dyu(grd%im,grd%jm)); bmd%dyu = huge(bmd%dyu(1,1)) + ALLOCATE ( bmd%dyv(grd%im,grd%jm)); bmd%dyv = huge(bmd%dyv(1,1)) + ALLOCATE ( bmd%a1(grd%im,grd%jm)) ; bmd%a1 = huge( bmd%a1(1,1)) + ALLOCATE ( bmd%a2(grd%im,grd%jm)) ; bmd%a2 = huge( bmd%a2(1,1)) + ALLOCATE ( bmd%a3(grd%im,grd%jm)) ; bmd%a3 = huge( bmd%a3(1,1)) + ALLOCATE ( bmd%a4(grd%im,grd%jm)) ; bmd%a4 = huge( bmd%a4(1,1)) + ALLOCATE ( bmd%a0(grd%im,grd%jm)) ; bmd%a0 = huge( bmd%a0(1,1)) + ALLOCATE ( bmd%a00(grd%im,grd%jm)); bmd%a00 = huge(bmd%a00(1,1)) + ALLOCATE ( bmd%bx(grd%im,grd%jm)) ; bmd%bx = huge(bmd%bx(1,1)) + ALLOCATE ( bmd%by(grd%im,grd%jm)) ; bmd%by = huge(bmd%by(1,1)) + ALLOCATE ( bmd%b_x(grd%im,grd%jm,grd%km)) ; bmd%b_x = huge(bmd%b_x(1,1,1)) + ALLOCATE ( bmd%b_y(grd%im,grd%jm,grd%km)) ; bmd%b_y = huge(bmd%b_y(1,1,1)) + ALLOCATE ( bmd%dns(grd%im,grd%jm,grd%km)) ; bmd%dns = huge(bmd%dns(1,1,1)) + ALLOCATE ( bmd%bxby(grd%im,grd%jm)) ; bmd%bxby = huge(bmd%bxby(1,1)) + ALLOCATE ( bmd%rgh(grd%im,grd%jm)) ; bmd%rgh = huge(bmd%rgh(1,1)) + ALLOCATE ( bmd%etb(grd%im,grd%jm)) ; bmd%etb = huge(bmd%etb(1,1)) + ALLOCATE ( bmd%ub(grd%im,grd%jm)) ; bmd%ub = huge(bmd%ub(1,1)) + ALLOCATE ( bmd%vb(grd%im,grd%jm)) ; bmd%vb = huge(bmd%vb(1,1)) + ALLOCATE ( bmd%etn(grd%im,grd%jm)) ; bmd%etn = huge(bmd%etn(1,1)) + ALLOCATE ( bmd%un(grd%im,grd%jm)) ; bmd%un = huge(bmd%un(1,1)) + ALLOCATE ( bmd%vn(grd%im,grd%jm)) ; bmd%vn = huge(bmd%vn(1,1)) + ALLOCATE ( bmd%eta(grd%im,grd%jm)) ; bmd%eta = huge(bmd%eta(1,1)) + ALLOCATE ( bmd%ua(grd%im,grd%jm)) ; bmd%ua = huge(bmd%ua(1,1)) + ALLOCATE ( bmd%va(grd%im,grd%jm)) ; bmd%va = huge(bmd%va(1,1)) + ALLOCATE ( bmd%etm(grd%im,grd%jm)) ; bmd%etm = huge(bmd%etm(1,1)) + ALLOCATE ( bmd%um(grd%im,grd%jm)) ; bmd%um = huge(bmd%um(1,1)) + ALLOCATE ( bmd%vm(grd%im,grd%jm)) ; bmd%vm = huge(bmd%vm(1,1)) + ALLOCATE ( bmd%div(grd%im,grd%jm)) ; bmd%div = huge(bmd%div(1,1)) + ALLOCATE ( bmd%cu(grd%im,grd%jm)) ; bmd%cu = huge(bmd%cu(1,1)) + ALLOCATE ( bmd%cv(grd%im,grd%jm)) ; bmd%cv = huge(bmd%cv(1,1)) + ALLOCATE ( bmd%dux(grd%im,grd%jm)) ; bmd%dux = huge(bmd%dux(1,1)) + ALLOCATE ( bmd%duy(grd%im,grd%jm)) ; bmd%duy = huge(bmd%duy(1,1)) + ALLOCATE ( bmd%dvx(grd%im,grd%jm)) ; bmd%dvx = huge(bmd%dvx(1,1)) + ALLOCATE ( bmd%dvy(grd%im,grd%jm)) ; bmd%dvy = huge(bmd%dvy(1,1)) + ALLOCATE ( bmd%etx(grd%im,grd%jm)) ; bmd%etx = huge(bmd%etx(1,1)) + ALLOCATE ( bmd%ety(grd%im,grd%jm)) ; bmd%ety = huge(bmd%ety(1,1)); + + + bmd%itr(:) = 0 + + do j=1,grd%jm + do i=1,grd%im + if(grd%hgt(i,j).gt.0.0) then +! bmd%hgt(i,j) = max(15.,grd%hgt(i,j)) + bmd%hgt(i,j) = grd%hgt(i,j) + else + bmd%hgt(i,j) = 0.0 + endif + enddo + enddo +! bmd%hgt(:,:) = grd%hgt(:,:) + + bmd%hgt(1,:) = 0.0 + bmd%hgt(:,1) = 0.0 + bmd%hgt(grd%im,:) = 0.0 + bmd%hgt(:,grd%jm) = 0.0 + +!------------------------------------------------- + + do j=1,grd%jm + do i=1,grd%im + if(bmd%hgt(i,j).gt.0.0) then + bmd%mst(i,j) = 1.0 + else + bmd%mst(i,j) = 0.0 + endif + enddo + enddo + + bmd%bnm = 0.0 + do j=2,grd%jm-1 + do i=2,grd%im-1 + if(bmd%mst(i,j).eq.1.) bmd%bnm = bmd%bnm + 1. + enddo + enddo + + do j=1,grd%jm + do i=2,grd%im +! bmd%hgu(i,j) = (bmd%hgt(i,j)+bmd%hgt(i-1,j))*0.5 + bmd%hgu(i,j) = min(bmd%hgt(i,j),bmd%hgt(i-1,j)) + bmd%dxu(i,j) = (grd%dx(i,j)+grd%dx(i-1,j))*0.5 + bmd%dyu(i,j) = (grd%dy(i,j)+grd%dy(i-1,j))*0.5 + bmd%msu(i,j) = bmd%mst(i,j)*bmd%mst(i-1,j) + enddo + enddo + bmd%dxu(1,:) = bmd%dxu(2,:) + bmd%dyu(1,:) = bmd%dyu(2,:) + bmd%msu(1,:) = 0.0 + do j=2,grd%jm + do i=1,grd%im +! bmd%hgv(i,j) = (bmd%hgt(i,j)+bmd%hgt(i,j-1))*0.5 + bmd%hgv(i,j) = min(bmd%hgt(i,j),bmd%hgt(i,j-1)) + bmd%dxv(i,j) = (grd%dx(i,j)+grd%dx(i,j-1))*0.5 + bmd%dyv(i,j) = (grd%dy(i,j)+grd%dy(i,j-1))*0.5 + bmd%msv(i,j) = bmd%mst(i,j)*bmd%mst(i,j-1) + enddo + enddo + bmd%dxv(:,1) = bmd%dxv(:,2) + bmd%dyv(:,1) = bmd%dyv(:,2) + bmd%msv(:,1) = 0.0 + + do j= 2,grd%jm-1 + do i= 2,grd%im-1 + bmd%a1(i,j) = bmd%alp1**2 *(bmd%dt**2)*bmd%g*bmd%hgu(i+1,j)/grd%dx(i,j)**2*bmd%msu(i+1,j) + bmd%a2(i,j) = bmd%alp1**2 *(bmd%dt**2)*bmd%g*bmd%hgu(i ,j)/grd%dx(i,j)**2*bmd%msu(i ,j) + bmd%a3(i,j) = bmd%alp1**2 *(bmd%dt**2)*bmd%g*bmd%hgv(i,j+1)/grd%dy(i,j)**2*bmd%msv(i,j+1) + bmd%a4(i,j) = bmd%alp1**2 *(bmd%dt**2)*bmd%g*bmd%hgv(i,j )/grd%dy(i,j)**2*bmd%msv(i,j ) + bmd%a0(i,j) = (bmd%a1(i,j)+bmd%a2(i,j)+bmd%a3(i,j)+bmd%a4(i,j) +1.0) + bmd%a00(i,j) = (bmd%a1(i,j)+bmd%a2(i,j)+bmd%a3(i,j)+bmd%a4(i,j)) *bmd%mst(i,j) + enddo + enddo + + +end subroutine ini_bmd diff --git a/ini_cfn.f90 b/ini_cfn.f90 new file mode 100644 index 0000000..cf1966d --- /dev/null +++ b/ini_cfn.f90 @@ -0,0 +1,103 @@ +subroutine ini_cfn + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Initialise the minimisation ! +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + use set_knd + use drv_str + use obs_str + use grd_str + use eof_str + use ctl_str + + implicit none + + INTEGER(i4) :: i + + + ctl%task = 'START' + + ctl%iprint = 0 ! if 1 prints file iterate.dat + + ctl%factr=1.0d+7 + +! ctl%pgtol=1.0d-2 + + + if( drv%ktr.eq.1 .or. drv%ratio(drv%ktr).ne.1.0 ) then + +! --- +! Allocate memory for optimization arrays + + ctl%n = nSurfaceWaterpoints * ros%neof + write(drv%dia,*) 'Size of the control vector: ',ctl%n + ALLOCATE( ctl%nbd(ctl%n)) ; ctl%nbd = huge(ctl%nbd(1)) + ALLOCATE(ctl%iwa(3*ctl%n)); ctl%iwa = huge(ctl%iwa(1)) + ALLOCATE( ctl%x_c(ctl%n)) ; ctl%x_c = huge(ctl%x_c(1)) + ALLOCATE( ctl%g_c(ctl%n)) ; ctl%g_c = huge(ctl%g_c(1)) + ALLOCATE( ctl%l_c(ctl%n)) ; ctl%l_c = huge(ctl%l_c(1)) + ALLOCATE( ctl%u_c(ctl%n)) ; ctl%u_c = huge(ctl%u_c(1)) + ALLOCATE( ctl%wa(8*ctl%m)); ctl%wa = huge(ctl%wa(1)) + ALLOCATE( ctl%sg(ctl%m)) ; ctl%sg = huge(ctl%sg(1)) + ALLOCATE( ctl%sgo(ctl%m)) ; ctl%sgo = huge(ctl%sgo(1)) + ALLOCATE( ctl%yg(ctl%m)) ; ctl%yg = huge(ctl%yg(1)) + ALLOCATE( ctl%ygo(ctl%m)) ; ctl%ygo = huge(ctl%ygo(1)) + + + + ALLOCATE( ctl%ws(ctl%n,ctl%m)) ; ctl%ws = huge(ctl%ws(1,1)) ; + ALLOCATE( ctl%wy(ctl%n,ctl%m)) ; ctl%wy = huge(ctl%wy(1,1)) + ALLOCATE( ctl%sy(ctl%m,ctl%m)) ; ctl%sy = huge(ctl%sy(1,1)) + ALLOCATE( ctl%ss(ctl%m,ctl%m)) ; ctl%ss = huge(ctl%ss(1,1)) + ALLOCATE( ctl%yy(ctl%m,ctl%m)) ; ctl%yy = huge(ctl%yy(1,1)) + + ALLOCATE( ctl%wt(ctl%m,ctl%m)) ; ctl%wt = huge(ctl%wt(1,1)) + ALLOCATE( ctl%wn(2*ctl%m,2*ctl%m)) ; ctl%wn = huge(ctl%wn(1,1)) + ALLOCATE( ctl%snd(2*ctl%m,2*ctl%m)) ; ctl%snd = huge(ctl%snd(1,1)) + + ALLOCATE( ctl%z_c(ctl%n)) ; ctl%z_c = huge(ctl%z_c(1)) + ALLOCATE( ctl%r_c(ctl%n)) ; ctl%r_c = huge(ctl%r_c(1)) + ALLOCATE( ctl%d_c(ctl%n)) ; ctl%d_c = huge(ctl%d_c(1)) + ALLOCATE( ctl%t_c(ctl%n)) ; ctl%t_c = huge(ctl%t_c(1)) + + + do i=1,ctl%n + ctl%nbd(i)=0 + ctl%l_c(i)=-1.0d3 + ctl%u_c(i)= 1.0d3 + ctl%x_c(i)= 0.0d0 + enddo + + endif + ctl%f_c = 0.0 + ctl%csave = 'gnignigni' + ctl%lsave = .true. + ctl%isave = 0 + ctl%dsave = 0.0 + +end subroutine ini_cfn diff --git a/ini_itr.f90 b/ini_itr.f90 new file mode 100644 index 0000000..c55cb94 --- /dev/null +++ b/ini_itr.f90 @@ -0,0 +1,133 @@ +subroutine ini_itr + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Define the grid ! +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + + use set_knd + use drv_str + use grd_str + use eof_str + use ctl_str + + implicit none + + INTEGER(i4) :: i, j, k , ii, jj, kk + REAL(r8) :: ri, rj, p, q + REAL(r8) :: div_x, div_y + REAL(r8), ALLOCATABLE :: pq1(:,:), pq2(:,:), pq3(:,:), pq4(:,:) + INTEGER(i4), ALLOCATABLE :: i1(:,:), j1(:,:) + + + + ALLOCATE( pq1(grd%im,grd%jm) ); pq1 = huge(pq1(1,1)) + ALLOCATE( pq2(grd%im,grd%jm) ); pq2 = huge(pq2(1,1)) + ALLOCATE( pq3(grd%im,grd%jm) ); pq3 = huge(pq3(1,1)) + ALLOCATE( pq4(grd%im,grd%jm) ); pq4 = huge(pq4(1,1)) + ALLOCATE( i1(grd%im,grd%jm) ); i1 = huge(i1 (1,1)) + ALLOCATE( j1(grd%im,grd%jm) ); j1 = huge(j1 (1,1)) + +! --- +! Interpolate between grids + + do jj=1,grd%jm + do ii=1,grd%im + ri=max(1.,min(real(drv%im-1),real(ii-1)/real(drv%ratio(drv%ktr)) + 1.)) + i=int(ri) + p=ri-i + rj=max(1.,min(real(drv%jm-1),real(jj-1)/real(drv%ratio(drv%ktr)) + 1.)) + j=int(rj) + q=rj-j + + i1(ii,jj) = i + j1(ii,jj) = j + + div_y = (1.-q) * max(drv%msk(i,j ),drv%msk(i+1,j )) & + + q * max(drv%msk(i,j+1),drv%msk(i+1,j+1)) + div_x = (1.-p) * drv%msk(i ,j) + p * drv%msk(i+1,j) + pq1(ii,jj) = drv%msk(i,j) & + * max(drv%msk(i,j),drv%msk(i+1,j)) & + * (1.-p) * (1.-q) & + /( div_x * div_y + 1.e-16 ) + pq2(ii,jj) = drv%msk(i+1,j) & + * max(drv%msk(i,j),drv%msk(i+1,j)) & + * p * (1.-q) & + /( div_x * div_y + 1.e-16 ) + div_x = (1.-p) * drv%msk(i ,j+1) + p * drv%msk(i+1,j+1) + pq3(ii,jj) = drv%msk(i,j+1) & + * max(drv%msk(i,j+1),drv%msk(i+1,j+1)) & + * (1.-p) * q & + /( div_x * div_y + 1.e-16 ) + pq4(ii,jj) = drv%msk(i+1,j+1) & + * max(drv%msk(i,j+1),drv%msk(i+1,j+1)) & + * p * q & + /( div_x * div_y + 1.e-16 ) + + enddo + enddo + + + do k = 1,ros%neof + do jj=1,grd%jm + do ii=1,grd%im + i=i1(ii,jj) + j=j1(ii,jj) + grd%ro(ii,jj,k) = pq1(ii,jj) * drv%ro(i,j ,k) + pq2(ii,jj) * drv%ro(i+1,j ,k) & + + pq3(ii,jj) * drv%ro(i,j+1,k) + pq4(ii,jj) * drv%ro(i+1,j+1,k) + enddo + enddo + enddo + +! --- +! Reconstruct the control vector + kk = 0 + do k=1,ros%neof + do j=1,grd%jm + do i=1,grd%im + kk = kk+1 + ctl%x_c(kk) = grd%ro(i,j,k)/drv%ratio(drv%ktr) + enddo + enddo + enddo + + + DEALLOCATE( drv%ro, drv%ro_ad, drv%msk) + DEALLOCATE( pq1 ) + DEALLOCATE( pq2 ) + DEALLOCATE( pq3 ) + DEALLOCATE( pq4 ) + DEALLOCATE( i1 ) + DEALLOCATE( j1 ) + +! Calculate the cost function and its gradient + + call costf + + + +end subroutine ini_itr diff --git a/ini_nrm.f90 b/ini_nrm.f90 new file mode 100644 index 0000000..6eca289 --- /dev/null +++ b/ini_nrm.f90 @@ -0,0 +1,71 @@ +subroutine ini_nrm + + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Minimise the cost function ! +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + + use set_knd + use drv_str + use obs_str + use grd_str + use eof_str + use ctl_str + + implicit none + + INTEGER(i4) :: k + REAL(r8) :: maxpg + REAL(r8), allocatable, dimension (:) :: x_s, g_s + +! Save in temporary arrays + ALLOCATE ( x_s(ctl%n)) ; x_s(:) = ctl%x_c(:) + ALLOCATE ( g_s(ctl%n)) ; g_s(:) = ctl%g_c(:) + +! Initialize the control vector to zero + ctl%x_c(:) = 0.0 + +! Calculate the cost function and its gradient + call costf + +! Calculate the norm of the gradient + maxpg = 0.0 + do k=1,ctl%n + maxpg = max(maxpg,abs(ctl%g_c(k))) + enddo + + ctl%pgtol = maxpg * ctl%pgper + + print*,' maxpg is: ',maxpg, ctl%pgtol + + ctl%x_c(:) = x_s(:) + ctl%g_c(:) = g_s(:) + + DEALLOCATE ( x_s, g_s ) + +end subroutine ini_nrm diff --git a/int_par.f90 b/int_par.f90 new file mode 100644 index 0000000..799fd77 --- /dev/null +++ b/int_par.f90 @@ -0,0 +1,75 @@ +subroutine int_par + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Calculate interpolation parameters ! +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + + use set_knd + use obs_str + + implicit none + +#ifdef __FISICA +! ---- +! Load SLA observations + call int_par_sla + +! ---- +! Load ARGO observations + call int_par_arg + +! ---- +! Load XBT observations + call int_par_xbt + +! ---- +! Load glider observations + call int_par_gld + +! ---- +! Load observations of Argo trajectories + call int_par_tra + +! ---- +! Load observations of trajectories of surface drifters + call int_par_trd + +! ---- +! Load observations of drifter velocities + call int_par_vdr + +! ---- +! Load observations of glider velocities + call int_par_gvl + +#endif +! ---- +! Load observations of chlorophyll + call int_par_chl + +end subroutine int_par diff --git a/main.f90 b/main.f90 new file mode 100644 index 0000000..c6fd372 --- /dev/null +++ b/main.f90 @@ -0,0 +1,8 @@ +program ocean_var +use filenames +implicit none + +call SETFILENAMES +call oceanvar + +end program ocean_var diff --git a/min_cfn.f90 b/min_cfn.f90 new file mode 100644 index 0000000..ba62869 --- /dev/null +++ b/min_cfn.f90 @@ -0,0 +1,90 @@ +subroutine min_cfn + + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Minimise the cost function ! +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + + use set_knd + use drv_str + use obs_str + use grd_str + use eof_str + use ctl_str + + implicit none + + INTEGER(i4) :: cntr, k +!anna --- Stopping criteria on number of minimization steps +! INTEGER(i4) :: nstp +!anna --- + REAL(r8) :: maxpg + + cntr = 0 + +!anna +! nstp=0 +!anna + + + + do while(ctl%task(1:5).eq.'NEW_X' .or. ctl%task(1:2).eq.'FG' .or. ctl%task(1:5).eq.'START') +!anna +! do while((ctl%task(1:5).eq.'NEW_X' .or. ctl%task(1:2).eq.'FG' .or. ctl%task(1:5).eq.'START').and.nstp.le.300) +!anna + + + call setulb(ctl%n, ctl%m, ctl%x_c, ctl%l_c, ctl%u_c, ctl%nbd, ctl%f_c, ctl%g_c, & + ctl%factr, ctl%pgtol, ctl%ws, ctl%wy, ctl%sy, ctl%ss, ctl%wt, & + ctl%wn, ctl%snd, ctl%z_c, ctl%r_c, ctl%d_c, ctl%t_c, ctl%wa, & + ctl%iwa, & + ctl%task, ctl%iprint, ctl%csave, ctl%lsave, ctl%isave, ctl%dsave) +!anna +! ctl%task, ctl%iprint, ctl%csave, ctl%lsave, ctl%isave, ctl%dsave,nstp) + + + if (ctl%task(1:2) .eq. 'FG') then + +! Calculate the cost function and its gradient + call costf + +! Modify the stopping criteria + if(cntr.eq.0 .and. ctl%pgper.ne.0.0 .and. drv%ktr.eq.1 )then + maxpg = 0.0 + do k=1,ctl%n + maxpg = max(maxpg,abs(ctl%g_c(k))) + enddo + ctl%pgtol = maxpg * ctl%pgper + cntr = 1 + endif + + endif + + enddo !while + +end subroutine min_cfn diff --git a/netcdf_err.f90 b/netcdf_err.f90 new file mode 100644 index 0000000..fa411ca --- /dev/null +++ b/netcdf_err.f90 @@ -0,0 +1,38 @@ +subroutine netcdf_err(errcode) + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + + use set_knd + use netcdf + + implicit none + + INTEGER(i4), intent(in) :: errcode + + if(errcode /= nf90_noerr) then + print*,'Netcdf Error: ', trim(nf90_strerror(errcode)) + !stop "Stopped" + call f_exit(24) + endif + +end subroutine netcdf_err + diff --git a/obs_chl.f90 b/obs_chl.f90 new file mode 100644 index 0000000..f980e55 --- /dev/null +++ b/obs_chl.f90 @@ -0,0 +1,63 @@ +subroutine obs_chl + +!--------------------------------------------------------------------------- +! ! +! Copyright 2007 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Apply observational operator for chlorophyll ! +! ! +!----------------------------------------------------------------------- + + + use set_knd + use grd_str + use obs_str + + implicit none + + INTEGER(i4) :: i, j, k, l, kk + + do kk = 1,chl%no + + if(chl%flc(kk).eq.1 )then + + + i=chl%ib(kk) + j=chl%jb(kk) + + chl%inc(kk) = 0.0 + + do l=1,grd%nchl + do k=1,chl%kb(kk) + chl%inc(kk) = chl%inc(kk) + ( & + chl%pq1(kk) * grd%chl(i ,j ,k,l) + & + chl%pq2(kk) * grd%chl(i+1,j ,k,l) + & + chl%pq3(kk) * grd%chl(i ,j+1,k,l) + & + chl%pq4(kk) * grd%chl(i+1,j+1,k,l) ) * chl%dzr(k,kk) + enddo + enddo + + endif + + enddo + +end subroutine obs_chl diff --git a/obs_chl_ad.f90 b/obs_chl_ad.f90 new file mode 100644 index 0000000..ecf656a --- /dev/null +++ b/obs_chl_ad.f90 @@ -0,0 +1,63 @@ +subroutine obs_chl_ad + +!--------------------------------------------------------------------------- +! ! +! Copyright 2007 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Apply observational operator for velocities from gliders (adjoint) ! +! ! +! Version 1: S.Dobricic 2007 ! +!----------------------------------------------------------------------- + + + use set_knd + use grd_str + use obs_str + + implicit none + + INTEGER(i4) :: i, j, k, kk, l + + do kk = 1,chl%no + + if(chl%flc(kk).eq.1)then + + obs%k = obs%k + 1 + + i=chl%ib(kk) + j=chl%jb(kk) + + do l=1,grd%nchl + do k=1,chl%kb(kk) + grd%chl_ad(i ,j ,k,l) = grd%chl_ad(i ,j ,k,l) + chl%pq1(kk) * chl%dzr(k,kk) * obs%gra(obs%k) + grd%chl_ad(i+1,j ,k,l) = grd%chl_ad(i+1,j ,k,l) + chl%pq2(kk) * chl%dzr(k,kk) * obs%gra(obs%k) + grd%chl_ad(i ,j+1,k,l) = grd%chl_ad(i ,j+1,k,l) + chl%pq3(kk) * chl%dzr(k,kk) * obs%gra(obs%k) + grd%chl_ad(i+1,j+1,k,l) = grd%chl_ad(i+1,j+1,k,l) + chl%pq4(kk) * chl%dzr(k,kk) * obs%gra(obs%k) + enddo + enddo + + endif + + enddo + + +end subroutine obs_chl_ad diff --git a/obs_str.f90 b/obs_str.f90 new file mode 100644 index 0000000..18195a4 --- /dev/null +++ b/obs_str.f90 @@ -0,0 +1,475 @@ +MODULE obs_str + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Observational vectors ! +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + use set_knd + +implicit none + +public + +! --- +! Observational vector in the cost function + TYPE obs_t + + INTEGER(i8) :: no ! Number of observations + INTEGER(i8) :: k ! Observation index + REAL(r8), POINTER :: inc(:) ! Increments + REAL(r8), POINTER :: amo(:) ! Analysis - observation + REAL(r8), POINTER :: res(:) ! residual + REAL(r8), POINTER :: err(:) ! Observational error + REAL(r8), POINTER :: gra(:) ! Observational gradient + INTEGER(i8) :: sla ! Flag for assimilation of SLA + INTEGER(i8) :: arg ! Flag for assimilation of ARGO floats + INTEGER(i8) :: xbt ! Flag for assimilation of XBTs + INTEGER(i8) :: gld ! Flag for assimilation of gliders + INTEGER(i8) :: tra ! Flag for assimilation of Argo trajectories + INTEGER(i8) :: trd ! Flag for assimilation of driftres trajectories + INTEGER(i8) :: vdr ! Flag for assimilation of velocities by drifters + INTEGER(i8) :: gvl ! Flag for assimilation of velocities by gliders + INTEGER(i8) :: chl ! Flag for assimilation of chlorophyll + + END TYPE obs_t + + TYPE (obs_t) :: obs + +! --- +! Observational vector for SLA + TYPE sla_t + + INTEGER(i8) :: no ! Number of all observations + INTEGER(i8) :: nc ! Number of good observations + REAL(r8) :: dep ! Minimum depth for observations + INTEGER(i8) :: kdp ! Model level corresponding to dep + INTEGER(i8), POINTER :: ino(:) ! Instrument + INTEGER(i8), POINTER :: flg(:) ! Quality flag + INTEGER(i8), POINTER :: flc(:) ! Temporary flag for multigrid + REAL(r8), POINTER :: lon(:) ! Longitute + REAL(r8), POINTER :: lat(:) ! Latitude + REAL(r8), POINTER :: tim(:) ! Time + REAL(r8), POINTER :: val(:) ! Observed value + REAL(r8), POINTER :: bac(:) ! Background value + REAL(r8), POINTER :: inc(:) ! Increments + REAL(r8), POINTER :: bia(:) ! Bias + REAL(r8), POINTER :: err(:) ! Observational error + REAL(r8), POINTER :: res(:) ! residual + REAL(r8), POINTER :: b_a(:) ! Background - analyses + INTEGER(i8), POINTER :: ib(:) ! i index of the nearest west point + REAL(r8) , POINTER :: pb(:) ! distance from the nearest west point + INTEGER(i8), POINTER :: jb(:) ! j index of the nearest south point + REAL(r8) , POINTER :: qb(:) ! distance from the nearest south point + REAL(r8) , POINTER :: pq1(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq2(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq3(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq4(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: dpt(:) ! Maximum depth of surrounding points + + END TYPE sla_t + + TYPE (sla_t) :: sla + +! --- +! Observational vector for ARGO floats + TYPE arg_t + + INTEGER(i8) :: no ! Number of all observations + INTEGER(i8) :: nc ! Number of good observations + REAL(r8) :: dep ! Minimum depth for observations + INTEGER(i8) :: kdp ! Model level corresponding to dep + INTEGER(i8), POINTER :: ino(:) ! Float number + INTEGER(i8), POINTER :: par(:) ! Parameter flag (1-temperature, 2-salinity) + INTEGER(i8), POINTER :: flg(:) ! Quality flag + INTEGER(i8), POINTER :: flc(:) ! Temporary flag for multigrid + REAL(r8), POINTER :: lon(:) ! Longitute + REAL(r8), POINTER :: lat(:) ! Latitude + REAL(r8), POINTER :: dpt(:) ! Depth + REAL(r8), POINTER :: tim(:) ! Time + REAL(r8), POINTER :: val(:) ! Observed value + REAL(r8), POINTER :: bac(:) ! Background value + REAL(r8), POINTER :: inc(:) ! Increments + REAL(r8), POINTER :: bia(:) ! Bias + REAL(r8), POINTER :: err(:) ! Observational error + REAL(r8), POINTER :: res(:) ! residual + REAL(r8), POINTER :: b_a(:) ! Background - analyses + INTEGER(i8), POINTER :: ib(:) ! i index of the nearest west point + REAL(r8) , POINTER :: pb(:) ! distance from the nearest west point + INTEGER(i8), POINTER :: jb(:) ! j index of the nearest south point + REAL(r8) , POINTER :: qb(:) ! distance from the nearest south point + INTEGER(i8), POINTER :: kb(:) ! k index of the nearest point below + REAL(r8) , POINTER :: rb(:) ! distance from the nearest point below + REAL(r8) , POINTER :: pq1(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq2(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq3(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq4(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq5(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq6(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq7(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq8(:) ! Interpolation parameter for masked grids + + END TYPE arg_t + + TYPE (arg_t) :: arg + +! --- +! Observational vector for XBT profiles + TYPE xbt_t + + INTEGER(i8) :: no ! Number of all observations + INTEGER(i8) :: nc ! Number of good observations + REAL(r8) :: dep ! Minimum depth for observations + INTEGER(i8) :: kdp ! Model level corresponding to dep + INTEGER(i8), POINTER :: ino(:) ! Float number + INTEGER(i8), POINTER :: par(:) ! Parameter flag (1-temperature) + INTEGER(i8), POINTER :: flg(:) ! Quality flag + INTEGER(i8), POINTER :: flc(:) ! Temporary flag for multigrid + REAL(r8), POINTER :: lon(:) ! Longitute + REAL(r8), POINTER :: lat(:) ! Latitude + REAL(r8), POINTER :: dpt(:) ! Depth + REAL(r8), POINTER :: tim(:) ! Time + REAL(r8), POINTER :: val(:) ! Observed value + REAL(r8), POINTER :: bac(:) ! Background value + REAL(r8), POINTER :: inc(:) ! Increments + REAL(r8), POINTER :: bia(:) ! Bias + REAL(r8), POINTER :: err(:) ! Observational error + REAL(r8), POINTER :: res(:) ! residual + REAL(r8), POINTER :: b_a(:) ! Background - analyses + INTEGER(i8), POINTER :: ib(:) ! i index of the nearest west point + REAL(r8) , POINTER :: pb(:) ! distance from the nearest west point + INTEGER(i8), POINTER :: jb(:) ! j index of the nearest south point + REAL(r8) , POINTER :: qb(:) ! distance from the nearest south point + INTEGER(i8), POINTER :: kb(:) ! k index of the nearest point below + REAL(r8) , POINTER :: rb(:) ! distance from the nearest point below + REAL(r8) , POINTER :: pq1(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq2(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq3(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq4(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq5(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq6(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq7(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq8(:) ! Interpolation parameter for masked grids + + END TYPE xbt_t + + TYPE (xbt_t) :: xbt + +! --- +! Observational vector for gliders + TYPE gld_t + + INTEGER(i8) :: no ! Number of all observations + INTEGER(i8) :: nc ! Number of good observations + REAL(r8) :: dep ! Minimum depth for observations + INTEGER(i8) :: kdp ! Model level corresponding to dep + INTEGER(i8), POINTER :: ino(:) ! Glider number + INTEGER(i8), POINTER :: par(:) ! Parameter flag (1-temperature, 2-salinity) + INTEGER(i8), POINTER :: flg(:) ! Quality flag + INTEGER(i8), POINTER :: flc(:) ! Temporary flag for multigrid + REAL(r8), POINTER :: lon(:) ! Longitute + REAL(r8), POINTER :: lat(:) ! Latitude + REAL(r8), POINTER :: dpt(:) ! Depth + REAL(r8), POINTER :: tim(:) ! Time + REAL(r8), POINTER :: val(:) ! Observed value + REAL(r8), POINTER :: bac(:) ! Background value + REAL(r8), POINTER :: inc(:) ! Increments + REAL(r8), POINTER :: bia(:) ! Bias + REAL(r8), POINTER :: err(:) ! Observational error + REAL(r8), POINTER :: res(:) ! residual + REAL(r8), POINTER :: b_a(:) ! Background - analyses + INTEGER(i8), POINTER :: ib(:) ! i index of the nearest west point + REAL(r8) , POINTER :: pb(:) ! distance from the nearest west point + INTEGER(i8), POINTER :: jb(:) ! j index of the nearest south point + REAL(r8) , POINTER :: qb(:) ! distance from the nearest south point + INTEGER(i8), POINTER :: kb(:) ! k index of the nearest point below + REAL(r8) , POINTER :: rb(:) ! distance from the nearest point below + REAL(r8) , POINTER :: pq1(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq2(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq3(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq4(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq5(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq6(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq7(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq8(:) ! Interpolation parameter for masked grids + + END TYPE gld_t + + TYPE (gld_t) :: gld + +! --- +! Observational vector for Argo trajectories + TYPE tra_t + + INTEGER(i8) :: no ! Number of all observations + INTEGER(i8) :: nc ! Number of good observations + INTEGER(i8) :: nt ! Number of time steps + INTEGER(I8) :: im ! I dimension of the grid + INTEGER(I8) :: jm ! J dimension of the grid + INTEGER(I8) :: km ! K dimension of the grid + REAL(r8) :: dpt ! Depth of observations + INTEGER(i8), POINTER :: flg(:) ! Quality flag + INTEGER(i8), POINTER :: flc(:) ! Temporary flag for multigrid + INTEGER(i8), POINTER :: ino(:) ! Float number + REAL(r8), POINTER :: dtm(:) ! Time spent under surface + REAL(r8), POINTER :: loi(:) ! Initial observed longitude + REAL(r8), POINTER :: lai(:) ! Initial observed latitude + REAL(r8), POINTER :: lof(:) ! Final observed longitude + REAL(r8), POINTER :: laf(:) ! Final observed latitude + REAL(r8), POINTER :: lob(:,:) ! Longitudes of simulated positions + REAL(r8), POINTER :: lab(:,:) ! Latitudes of simulated positions + REAL(r8), POINTER :: loa(:) ! Longitudes of analysed positions + REAL(r8), POINTER :: laa(:) ! Latitudes of analysed positions + REAL(r8), POINTER :: xob(:) ! Observed value in x direction + REAL(r8), POINTER :: erx(:) ! Observational error in x direction + REAL(r8), POINTER :: rex(:) ! Residual in x direction + REAL(r8), POINTER :: inx(:) ! Increments in x direction + REAL(r8), POINTER :: yob(:) ! Observed value in y direction + REAL(r8), POINTER :: ery(:) ! Observational error in y direction + REAL(r8), POINTER :: rey(:) ! Residual in y direction + REAL(r8), POINTER :: iny(:) ! Increments in y direction + REAL(r8), POINTER :: err(:) ! Observational error in meters + REAL(r8) , POINTER :: umn(:,:) ! U component of background velocity + REAL(r8) , POINTER :: vmn(:,:) ! V component of background velocity + REAL(r8) , POINTER :: dx(:,:) ! Delta x on trajectory grid + REAL(r8) , POINTER :: dy(:,:) ! Delta x on trajectory grid + REAL(r8) , POINTER :: lon(:,:) ! Longitudes of grid points + REAL(r8) , POINTER :: lat(:,:) ! Latitudes of grid points + REAL(r8) , POINTER :: xmn(:,:) ! X coordinate of mean trajectory position + REAL(r8) , POINTER :: ymn(:,:) ! Y coordinate of mean trajectory position + REAL(r8) , POINTER :: tim(:) ! Time of the duration of the trajectory + REAL(r8) , POINTER :: xtl(:) ! Delta X of trajectory correction + REAL(r8) , POINTER :: ytl(:) ! Delta Y of trajectory correction + REAL(r8) , POINTER :: xtl_ad(:) ! Delta X of trajectory correction (adjoint) + REAL(r8) , POINTER :: ytl_ad(:) ! Delta Y of trajectory correction (adjoint) + INTEGER(i8), POINTER :: i1(:,:) ! i index for interpolation between grids + INTEGER(i8), POINTER :: j1(:,:) ! j index for interpolation between grids + REAL(r8) , POINTER :: pq1(:,:) ! Parameter for interpolation between grids + REAL(r8) , POINTER :: pq2(:,:) ! Parameter for interpolation between grids + REAL(r8) , POINTER :: pq3(:,:) ! Parameter for interpolation between grids + REAL(r8) , POINTER :: pq4(:,:) ! Parameter for interpolation between grids + REAL(r8) , POINTER :: uvl(:,:) ! Delta u on trajectory grid + REAL(r8) , POINTER :: vvl(:,:) ! Delta v on trajectory grid + REAL(r8) , POINTER :: uvl_ad(:,:)! Delta u on trajectory grid (adjoint) + REAL(r8) , POINTER :: vvl_ad(:,:)! Delta v on trajectory grid (adjoint) + + + END TYPE tra_t + + TYPE (tra_t) :: tra + +! --- +! Observational vector for trajectories of surface drifters + TYPE trd_t + + INTEGER(i8) :: no ! Number of all observations + INTEGER(i8) :: nc ! Number of good observations + INTEGER(i8) :: nt ! Number of time steps + INTEGER(I8) :: im ! I dimension of the grid + INTEGER(I8) :: jm ! J dimension of the grid + INTEGER(I8) :: km ! K dimension of the grid + REAL(r8) :: dpt ! Depth of observations + INTEGER(i8), POINTER :: flg(:) ! Quality flag + INTEGER(i8), POINTER :: flc(:) ! Temporary flag for multigrid + INTEGER(i8), POINTER :: ino(:) ! Float number + REAL(r8), POINTER :: dtm(:) ! Time spent under surface + REAL(r8), POINTER :: loi(:) ! Initial observed longitude + REAL(r8), POINTER :: lai(:) ! Initial observed latitude + REAL(r8), POINTER :: lof(:) ! Final observed longitude + REAL(r8), POINTER :: laf(:) ! Final observed latitude + REAL(r8), POINTER :: lob(:,:) ! Longitudes of simulated positions + REAL(r8), POINTER :: lab(:,:) ! Latitudes of simulated positions + REAL(r8), POINTER :: loa(:) ! Longitudes of analysed positions + REAL(r8), POINTER :: laa(:) ! Latitudes of analysed positions + REAL(r8), POINTER :: xob(:) ! Observed value in x direction + REAL(r8), POINTER :: erx(:) ! Observational error in x direction + REAL(r8), POINTER :: rex(:) ! Residual in x direction + REAL(r8), POINTER :: inx(:) ! Increments in x direction + REAL(r8), POINTER :: yob(:) ! Observed value in y direction + REAL(r8), POINTER :: ery(:) ! Observational error in y direction + REAL(r8), POINTER :: rey(:) ! Residual in y direction + REAL(r8), POINTER :: iny(:) ! Increments in y direction + REAL(r8), POINTER :: err(:) ! Observational error in meters + REAL(r8) , POINTER :: umn(:,:) ! U component of background velocity + REAL(r8) , POINTER :: vmn(:,:) ! V component of background velocity + REAL(r8) , POINTER :: dx(:,:) ! Delta x on trajectory grid + REAL(r8) , POINTER :: dy(:,:) ! Delta x on trajectory grid + REAL(r8) , POINTER :: lon(:,:) ! Longitudes of grid points + REAL(r8) , POINTER :: lat(:,:) ! Latitudes of grid points + REAL(r8) , POINTER :: xmn(:,:) ! X coordinate of mean trajectory position + REAL(r8) , POINTER :: ymn(:,:) ! Y coordinate of mean trajectory position + REAL(r8) , POINTER :: tim(:) ! Time of the duration of the trajectory + REAL(r8) , POINTER :: xtl(:) ! Delta X of trajectory correction + REAL(r8) , POINTER :: ytl(:) ! Delta Y of trajectory correction + REAL(r8) , POINTER :: xtl_ad(:) ! Delta X of trajectory correction (adjoint) + REAL(r8) , POINTER :: ytl_ad(:) ! Delta Y of trajectory correction (adjoint) + INTEGER(i8), POINTER :: i1(:,:) ! i index for interpolation between grids + INTEGER(i8), POINTER :: j1(:,:) ! j index for interpolation between grids + REAL(r8) , POINTER :: pq1(:,:) ! Parameter for interpolation between grids + REAL(r8) , POINTER :: pq2(:,:) ! Parameter for interpolation between grids + REAL(r8) , POINTER :: pq3(:,:) ! Parameter for interpolation between grids + REAL(r8) , POINTER :: pq4(:,:) ! Parameter for interpolation between grids + REAL(r8) , POINTER :: uvl(:,:) ! Delta u on trajectory grid + REAL(r8) , POINTER :: vvl(:,:) ! Delta v on trajectory grid + REAL(r8) , POINTER :: uvl_ad(:,:)! Delta u on trajectory grid (adjoint) + REAL(r8) , POINTER :: vvl_ad(:,:)! Delta v on trajectory grid (adjoint) + + + END TYPE trd_t + + TYPE (trd_t) :: trd + +! --- +! Observational vector for velocity from drifters + TYPE vdr_t + + INTEGER(i8) :: no ! Number of all observations + INTEGER(i8) :: nc ! Number of good observations + REAL(r8) :: dep ! Minimum depth for observations + INTEGER(i8), POINTER :: flg(:) ! Quality flag + INTEGER(i8), POINTER :: flc(:) ! Temporary flag for multigrid + INTEGER(i8), POINTER :: ino(:) ! Float number + INTEGER(i8), POINTER :: par(:) ! Parameter flag (1 - u component, 2 - v component) + REAL(r8), POINTER :: lon(:) ! Longitude + REAL(r8), POINTER :: lat(:) ! Latitude + REAL(r8), POINTER :: dpt(:) ! Depth + INTEGER(i8), POINTER :: kdp(:) ! Model level corresponding to dep + REAL(r8), POINTER :: tim(:) ! Time + REAL(r8), POINTER :: tms(:) ! Starting time for averaging + REAL(r8), POINTER :: tme(:) ! Final time for averaging + REAL(r8), POINTER :: val(:) ! Observed value + REAL(r8), POINTER :: bac(:) ! Background value + REAL(r8), POINTER :: inc(:) ! Increments + REAL(r8), POINTER :: bia(:) ! Bias + REAL(r8), POINTER :: err(:) ! Observational error + REAL(r8), POINTER :: res(:) ! residual + REAL(r8), POINTER :: b_a(:) ! Background - analyses + INTEGER(i8), POINTER :: ib(:) ! i index of the nearest west point + REAL(r8) , POINTER :: pb(:) ! distance from the nearest west point + INTEGER(i8), POINTER :: jb(:) ! j index of the nearest south point + REAL(r8) , POINTER :: qb(:) ! distance from the nearest south point + INTEGER(i8), POINTER :: nav(:) ! Number of time steps for averaging + INTEGER(i8), POINTER :: kb(:) ! k index of the nearest point below + REAL(r8) , POINTER :: rb(:) ! distance from the nearest point below + REAL(r8) , POINTER :: pq1(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq2(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq3(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq4(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq5(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq6(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq7(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq8(:) ! Interpolation parameter for masked grids + + END TYPE vdr_t + + TYPE (vdr_t) :: vdr + +! --- +! Observational vector for velocity from gliders + TYPE gvl_t + + INTEGER(i8) :: no ! Number of all observations + INTEGER(i8) :: nc ! Number of good observations + REAL(r8) :: dep ! Minimum depth for observations + INTEGER(i8), POINTER :: flg(:) ! Quality flag + INTEGER(i8), POINTER :: flc(:) ! Temporary flag for multigrid + INTEGER(i8), POINTER :: ino(:) ! Float number + INTEGER(i8), POINTER :: par(:) ! Parameter flag (1 - u component, 2 - v component) + REAL(r8), POINTER :: lon(:) ! Longitude + REAL(r8), POINTER :: lat(:) ! Latitude + REAL(r8), POINTER :: dpt(:) ! Depth + REAL(r8), POINTER :: dzr(:,:) ! Relative thickness + INTEGER(i8), POINTER :: kdp(:) ! Model level corresponding to dep + REAL(r8), POINTER :: tim(:) ! Time + REAL(r8), POINTER :: tms(:) ! Starting time for averaging + REAL(r8), POINTER :: tme(:) ! Final time for averaging + REAL(r8), POINTER :: val(:) ! Observed value + REAL(r8), POINTER :: bac(:) ! Background value + REAL(r8), POINTER :: inc(:) ! Increments + REAL(r8), POINTER :: bia(:) ! Bias + REAL(r8), POINTER :: err(:) ! Observational error + REAL(r8), POINTER :: res(:) ! residual + REAL(r8), POINTER :: b_a(:) ! Background - analyses + INTEGER(i8), POINTER :: ib(:) ! i index of the nearest west point + REAL(r8) , POINTER :: pb(:) ! distance from the nearest west point + INTEGER(i8), POINTER :: jb(:) ! j index of the nearest south point + REAL(r8) , POINTER :: qb(:) ! distance from the nearest south point + INTEGER(i8), POINTER :: nav(:) ! Number of time steps for averaging + INTEGER(i8), POINTER :: kb(:) ! k index of the nearest point below + REAL(r8) , POINTER :: rb(:) ! distance from the nearest point below + REAL(r8) , POINTER :: pq1(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq2(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq3(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq4(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq5(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq6(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq7(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq8(:) ! Interpolation parameter for masked grids + + END TYPE gvl_t + + TYPE (gvl_t) :: gvl + +! --- +! Observational vector for Chlorophyll + TYPE chl_t + + INTEGER(i8) :: no ! Number of all observations + INTEGER(i8) :: nc ! Number of good observations + REAL(r8) :: dep ! Minimum depth for observations + INTEGER(i8) :: kdp ! Model level corresponding to dep + INTEGER(i8), POINTER :: flg(:) ! Quality flag + INTEGER(i8), POINTER :: flc(:) ! Temporary flag for multigrid + REAL(r8), POINTER :: lon(:) ! Longitute + REAL(r8), POINTER :: lat(:) ! Latitude + REAL(r8), POINTER :: tim(:) ! Time + REAL(r8), POINTER :: val(:) ! Observed value + REAL(r8), POINTER :: bac(:) ! Background value + REAL(r8), POINTER :: inc(:) ! Increments + REAL(r8), POINTER :: bia(:) ! Bias + REAL(r8), POINTER :: err(:) ! Observational error + REAL(r8), POINTER :: res(:) ! residual + REAL(r8), POINTER :: b_a(:) ! Background - analyses + INTEGER(i8), POINTER :: ib(:) ! i index of the nearest west point + REAL(r8) , POINTER :: pb(:) ! distance from the nearest west point + INTEGER(i8), POINTER :: jb(:) ! j index of the nearest south point + REAL(r8) , POINTER :: qb(:) ! distance from the nearest south point + REAL(r8) , POINTER :: pq1(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq2(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq3(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: pq4(:) ! Interpolation parameter for masked grids + REAL(r8) , POINTER :: dpt(:) ! Maximum depth of surrounding points + INTEGER(i8), POINTER :: kb(:) ! k index of bottom point for vertical integration + REAL(r8), POINTER :: dzr(:,:) ! Relative thickness + + END TYPE chl_t + + TYPE (chl_t) :: chl + +! --- + + +END MODULE obs_str diff --git a/obs_vec.f90 b/obs_vec.f90 new file mode 100644 index 0000000..e71cebd --- /dev/null +++ b/obs_vec.f90 @@ -0,0 +1,154 @@ +subroutine obs_vec + + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Create the observational vector ! +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + + use set_knd + use drv_str + use obs_str + + implicit none + + INTEGER(i4) :: k, i + +! ------- +! Define observational vector + + obs%no = sla%nc + arg%nc + xbt%nc + gld%nc + 2 * tra%nc + 2 * trd%nc & + + vdr%nc + gvl%nc + chl%nc + + write(drv%dia,*) ' Total number of observations: ', obs%no + + ALLOCATE ( obs%inc(obs%no)) ; obs%inc = huge(obs%inc(1)) + ALLOCATE ( obs%amo(obs%no)) ; obs%amo = huge(obs%amo(1)) + ALLOCATE ( obs%res(obs%no)) ; obs%res = huge(obs%res(1)) + ALLOCATE ( obs%err(obs%no)) ; obs%err = huge(obs%err(1)) + ALLOCATE ( obs%gra(obs%no)) ; obs%gra = huge(obs%gra(1)) + + + k=0 + +! SLA observations + do i=1,sla%no + if(sla%flc(i).eq.1)then + k=k+1 + obs%res(k) = sla%res(i) + obs%err(k) = sla%err(i) + endif + enddo + +! ARGO observations + do i=1,arg%no + if(arg%flc(i).eq.1)then + k=k+1 + obs%res(k) = arg%res(i) + obs%err(k) = arg%err(i) + endif + enddo + +! XBT observations + do i=1,xbt%no + if(xbt%flc(i).eq.1)then + k=k+1 + obs%res(k) = xbt%res(i) + obs%err(k) = xbt%err(i) + endif + enddo + +! Glider observations + do i=1,gld%no + if(gld%flc(i).eq.1)then + k=k+1 + obs%res(k) = gld%res(i) + obs%err(k) = gld%err(i) + endif + enddo + +! Argo trajectory observations + do i=1,tra%no + if(tra%flc(i).eq.1)then + k=k+1 + obs%res(k) = tra%rex(i) + obs%err(k) = tra%erx(i) + endif + enddo + do i=1,tra%no + if(tra%flc(i).eq.1)then + k=k+1 + obs%res(k) = tra%rey(i) + obs%err(k) = tra%ery(i) + endif + enddo + +! Trajectory observations of surface drifters + do i=1,trd%no + if(trd%flc(i).eq.1)then + k=k+1 + obs%res(k) = trd%rex(i) + obs%err(k) = trd%erx(i) + endif + enddo + do i=1,trd%no + if(trd%flc(i).eq.1)then + k=k+1 + obs%res(k) = trd%rey(i) + obs%err(k) = trd%ery(i) + endif + enddo + +! Observations of drifter velocities + do i=1,vdr%no + if(vdr%flc(i).eq.1)then + k=k+1 + obs%res(k) = vdr%res(i) + obs%err(k) = vdr%err(i) + endif + enddo + +! Observations of glider velocities + do i=1,gvl%no + if(gvl%flc(i).eq.1)then + k=k+1 + obs%res(k) = gvl%res(i) + obs%err(k) = gvl%err(i) + endif + enddo + +! Observations of chlorophyll + do i=1,chl%no + if(chl%flc(i).eq.1)then + k=k+1 + obs%res(k) = chl%res(i) + obs%err(k) = chl%err(i) + endif + enddo + + +end subroutine obs_vec diff --git a/obsop.f90 b/obsop.f90 new file mode 100644 index 0000000..2675b08 --- /dev/null +++ b/obsop.f90 @@ -0,0 +1,75 @@ +subroutine obsop + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Apply observational operators +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + + use set_knd + use obs_str + + implicit none + +#ifdef __FISICA +! --- +! Satellite observations of SLA + call obs_sla + +! --- +! Observations by ARGO floats + call obs_arg + +! --- +! Observations by XBT profiles + call obs_xbt + +! --- +! Observations by gliders + call obs_gld + +! --- +! Observations of Argo trajectories + if(tra%no.gt.0) call obs_tra + +! --- +! Observations of trajectories of surface drifters + if(trd%no.gt.0) call obs_trd + +! --- +! Observations of velocities by drifters + call obs_vdr + +! --- +! Observations of velocities by gliders + call obs_gvl + +#endif +! --- +! Observations of chlorophyll + call obs_chl + +end subroutine obsop diff --git a/obsop_ad.f90 b/obsop_ad.f90 new file mode 100644 index 0000000..e9bf27f --- /dev/null +++ b/obsop_ad.f90 @@ -0,0 +1,77 @@ +subroutine obsop_ad + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Apply observational operators - adjoint +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + + use set_knd + use obs_str + + implicit none + + obs%k = 0 + +#ifdef __FISICA +! --- +! Satellite observations of SLA + call obs_sla_ad + +! --- +! ARGO observations + call obs_arg_ad + +! --- +! XBT observations + call obs_xbt_ad + +! --- +! Glider observations + call obs_gld_ad + +! --- +! Observations of Argo trajectories + if(tra%no.gt.0) call obs_tra_ad + +! --- +! Observations of trajectories of surface drifters + if(trd%no.gt.0) call obs_trd_ad + +! --- +! Observations of velocity from drifters + call obs_vdr_ad + +! --- +! Observations of velocity from gliders + call obs_gvl_ad + +#endif +! --- +! Observations of chlorophyll + call obs_chl_ad + +end subroutine obsop_ad diff --git a/oceanvar.f90 b/oceanvar.f90 new file mode 100644 index 0000000..61fbf30 --- /dev/null +++ b/oceanvar.f90 @@ -0,0 +1,138 @@ +subroutine oceanvar + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006, 2007 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! The main driver for the OceanVar ! +! ! +! Version 0.1: S.Dobricic 2006 ! +! Horizontal covariance with recursive filters, vertical with EOFs, ! +! assimilation of satellite observations of SLA, in situ observations! +! by XBT and ARGO floats ! +! ! +! Version 0.2: S.Dobricic 2007 ! +! Multigrid method. Internal boundaries for horizontal covariances. ! +! ! +!----------------------------------------------------------------------- + + use set_knd + use drv_str + + implicit none + + INTEGER(i4) :: ktr + +! --- +! Initialize diagnostics and read namelists + call def_nml +! --- +! Outer loop - multigrid + do ktr = 1,drv%ntr + drv%ktr = ktr + +! --- +! Define grid parameters + if( ktr.eq.1 .or. drv%ratio(ktr).ne.1.0 )then + call def_grd + + write(drv%dia,*) 'out of def_grd ' + endif + +! --- +! Get observations + if(ktr.eq.1) call get_obs + write(drv%dia,*) 'out of get_obs' + +! --- +! Define interpolation parameters + call int_par + write(drv%dia,*) 'out of int_par' + +! --- +! Define observational vector + call obs_vec + write(drv%dia,*) 'out of obs_vec' + +! --- +! Define constants for background covariances + if( ktr.eq.1 .or. drv%ratio(ktr).ne.1.0 ) then + call def_cov + write(drv%dia,*) 'out of def_cov ' + endif + +! --- +! Initialise barotropic model + if(drv%bmd(drv%ktr) .eq. 1) then + call ini_bmd + write(drv%dia,*) 'out of ini_bmd' + endif + +! --- +! Initialize cost function and its gradient + call ini_cfn + write(drv%dia,*) 'out of ini_cfn' + +! --- +! Calculate the initial norm the gradient + if( ktr.gt.1 ) then + call ini_nrm + write(drv%dia,*) 'out of ini_nrm ' + endif + +! --- +! Initialise from old iterration + if( ktr.gt.1 .and. drv%ratio(ktr).ne.1.0 ) then + call ini_itr + write(drv%dia,*) 'out of ini_itr ' + endif + +! --- +! Minimize the cost function (inner loop) + call min_cfn + write(drv%dia,*) 'out of min_cfn' + + if(ktr.eq.drv%ntr)then +! --- +! Convert to innovations + call cnv_inn +! --- +! Write outputs and diagnostics + call wrt_dia + endif + +! --- +! Save old iterration +! if( ktr.ne.drv%ntr)then +! if(drv%ratio(ktr+1).ne.1.0 ) then + call sav_itr + write(drv%dia,*) 'out of sav_itr ' +! endif +! endif + +! --- +! End of outer loop + enddo + +!----------------------------------------------------------------- +close(drv%dia) +end subroutine oceanvar diff --git a/rcfl_mod.f90 b/rcfl_mod.f90 new file mode 100644 index 0000000..fd63331 --- /dev/null +++ b/rcfl_mod.f90 @@ -0,0 +1,10 @@ +MODULE RCFL +use set_knd +implicit none + + REAL(r8), allocatable :: a_rcx(:,:,:), b_rcx(:,:,:), c_rcx(:,:,:) + REAL(r8), allocatable :: a_rcy(:,:,:), b_rcy(:,:,:), c_rcy(:,:,:) + REAL(r8), allocatable :: alp_rcx(:,:,:), bta_rcx(:,:,:) + REAL(r8), allocatable :: alp_rcy(:,:,:), bta_rcy(:,:,:) + +END MODULE RCFL diff --git a/rcfl_x.f90 b/rcfl_x.f90 new file mode 100644 index 0000000..8fd353d --- /dev/null +++ b/rcfl_x.f90 @@ -0,0 +1,120 @@ +subroutine rcfl_x( im, jm, km, imax, al, bt, fld, inx, imx) + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR a_rcx PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a_rcx copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Recursive filter in x direction ! +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + use set_knd + use cns_str + use rcfl + use grd_str + implicit none + + INTEGER(i4) :: im, jm, km, imax + + REAL(r8) :: fld(im,jm,km) + REAL(r8) :: al(jm,imax,km), bt(jm,imax,km) + INTEGER(i4) :: inx(im,jm,km), imx(km) + + + INTEGER(i4) :: i,j,k, ktr + INTEGER(i4) :: indSupWP + INTEGER nthreads, tid + integer :: OMP_GET_NUM_THREADS, OMP_GET_THREAD_NUM + +tid=1 +!$OMP PARALLEL & +!$OMP PRIVATE(k,j,i,ktr,indSupWP,tid) +!$ tid = OMP_GET_THREAD_NUM()+1 +!$OMP DO + do k=1,km + + a_rcx(:,:,tid) = 0.0 + b_rcx(:,:,tid) = 0.0 + c_rcx(:,:,tid) = 0.0 + + do j=1,jm + do i=1,im + a_rcx(j,inx(i,j,k),tid) = fld(i,j,k) + enddo + enddo + alp_rcx(:,:,tid) = al(:,:,k) + bta_rcx(:,:,tid) = bt(:,:,k) + + do ktr = 1,rcf%ntr + +! positive direction + if( ktr.eq.1 )then + b_rcx(:,1,tid) = (1.-alp_rcx(:,1,tid)) * a_rcx(:,1,tid) + elseif( ktr.eq.2 )then + b_rcx(:,1,tid) = a_rcx(:,1,tid) / (1.+alp_rcx(:,1,tid)) + else + b_rcx(:,1,tid) = (1.-alp_rcx(:,1,tid)) * (a_rcx(:,1,tid)-alp_rcx(:,1,tid)**3 * a_rcx(:,2,tid)) / (1.-alp_rcx(:,1,tid)**2)**2 + endif + + do j=2,imx(k) + b_rcx(:,j,tid) = alp_rcx(:,j,tid)*b_rcx(:,j-1,tid) + (1.-alp_rcx(:,j,tid))*a_rcx(:,j,tid) + enddo + +! negative direction + if( ktr.eq.1 )then + c_rcx(:,imx(k),tid) = b_rcx(:,imx(k),tid) / (1.+bta_rcx(:,imx(k),tid)) + else + c_rcx(:,imx(k),tid) = (1.-bta_rcx(:,imx(k),tid)) * & + (b_rcx(:,imx(k),tid)-bta_rcx(:,imx(k),tid)**3 * b_rcx(:,imx(k)-1,tid)) / (1.-bta_rcx(:,imx(k),tid)**2)**2 + endif + + do j=imx(k)-1,1,-1 + c_rcx(:,j,tid) = bta_rcx(:,j,tid)*c_rcx(:,j+1,tid) + (1.-bta_rcx(:,j,tid))*b_rcx(:,j,tid) + enddo + + a_rcx(:,:,tid) = c_rcx(:,:,tid) + + enddo + +! do j=1,jm +! do i=1,im +! fld(i,j,k) = a_rcx(j,inx(i,j,k)) +! enddo +! enddo +! This way fills land points with some values. +! We prefer not investigate at the mooment and use only the water points + do indSupWP=1,nSurfaceWaterPoints + i = SurfaceWaterPoints(1,indSupWP) + j = SurfaceWaterPoints(2,indSupWP) + fld(i,j,k) = a_rcx(j,inx(i,j,k),tid) + enddo + + + enddo +!$OMP END DO +!$OMP END PARALLEL + + + + +end subroutine rcfl_x diff --git a/rcfl_x_ad.f90 b/rcfl_x_ad.f90 new file mode 100644 index 0000000..d185987 --- /dev/null +++ b/rcfl_x_ad.f90 @@ -0,0 +1,131 @@ +subroutine rcfl_x_ad( im, jm, km, imax, al, bt, fld, inx, imx) + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR a_rcx PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a_rcx copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Recursive filter in x direction - adjoint +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + use set_knd + use cns_str + use rcfl + use grd_str + implicit none + + INTEGER(i4) :: im, jm, km, imax + + REAL(r8) :: fld(im,jm,km) + REAL(r8) :: al(jm,imax,km), bt(jm,imax,km) + INTEGER(i4) :: inx(im,jm,km), imx(km) + + + INTEGER(i4) :: i,j,k, ktr + INTEGER(i4) :: indSupWP + INTEGER nthreads, tid + integer :: OMP_GET_NUM_THREADS, OMP_GET_THREAD_NUM + +tid = 1 +!$OMP PARALLEL & +!$OMP PRIVATE(k,j,i,ktr,indSupWP,tid) +!$ tid = OMP_GET_THREAD_NUM()+1 + +!$OMP DO + do k=1,km + + a_rcx(:,:,tid) = 0.0 + b_rcx(:,:,tid) = 0.0 + c_rcx(:,:,tid) = 0.0 + + do j=1,jm + do i=1,im + c_rcx(j,inx(i,j,k),tid) = fld(i,j,k) + enddo + enddo + alp_rcx(:,:,tid) = al(:,:,k) + bta_rcx(:,:,tid) = bt(:,:,k) + + do ktr = 1,rcf%ntr + +! negative direction + b_rcx(:,:,tid) = 0.0 + + do j=1,imx(k)-1 + c_rcx(:,j+1,tid) = c_rcx(:,j+1,tid) + bta_rcx(:,j,tid)*c_rcx(:,j,tid) + b_rcx(:,j,tid) = (1.-bta_rcx(:,j,tid))*c_rcx(:,j,tid) + enddo + + + if( ktr.eq.1 )then + b_rcx(:,imx(k),tid) = b_rcx(:,imx(k),tid) + c_rcx(:,imx(k),tid) / (1.+bta_rcx(:,imx(k),tid)) + else + b_rcx(:,imx(k),tid) = b_rcx(:,imx(k),tid) + (1.-bta_rcx(:,imx(k),tid)) * c_rcx(:,imx(k),tid) / (1.-bta_rcx(:,imx(k),tid)**2)**2 + b_rcx(:,imx(k)-1,tid) = b_rcx(:,imx(k)-1,tid) - (1.-bta_rcx(:,imx(k),tid)) & + * bta_rcx(:,imx(k),tid)**3 * c_rcx(:,imx(k),tid) / (1.-bta_rcx(:,imx(k),tid)**2)**2 + endif + +! positive direction + a_rcx(:,:,tid) = 0.0 + + do j=imx(k),2,-1 + b_rcx(:,j-1,tid) = b_rcx(:,j-1,tid) + alp_rcx(:,j,tid)*b_rcx(:,j,tid) + a_rcx(:,j,tid) = a_rcx(:,j,tid) + (1.-alp_rcx(:,j,tid))*b_rcx(:,j,tid) + enddo + + + if( ktr.eq.1 )then + a_rcx(:,1,tid) = a_rcx(:,1,tid) + (1.-alp_rcx(:,1,tid)) * b_rcx(:,1,tid) + elseif( ktr.eq.2 )then + a_rcx(:,1,tid) = a_rcx(:,1,tid) + b_rcx(:,1,tid) / (1.+alp_rcx(:,1,tid)) + else + a_rcx(:,1,tid) = a_rcx(:,1,tid) + (1.-alp_rcx(:,1,tid)) * b_rcx(:,1,tid) / (1.-alp_rcx(:,1,tid)**2)**2 + a_rcx(:,2,tid) = a_rcx(:,2,tid) - (1.-alp_rcx(:,1,tid)) * alp_rcx(:,1,tid)**3 * b_rcx(:,1,tid) / (1.-alp_rcx(:,1,tid)**2)**2 + endif + + + c_rcx(:,:,tid) = a_rcx(:,:,tid) + + enddo + +! do j=1,jm +! do i=1,im +! fld(i,j,k) = c_rcx(j,inx(i,j,k)) +! enddo +! enddo +! This way fills land points with some values. +! We prefer not investigate at the mooment and use only the water points + do indSupWP=1,nSurfaceWaterPoints + i = SurfaceWaterPoints(1,indSupWP) + j = SurfaceWaterPoints(2,indSupWP) + fld(i,j,k) = c_rcx(j,inx(i,j,k),tid) + enddo + + + enddo +!$OMP END DO +!$OMP END PARALLEL + + + +end subroutine rcfl_x_ad diff --git a/rcfl_y.f90 b/rcfl_y.f90 new file mode 100644 index 0000000..d1b317a --- /dev/null +++ b/rcfl_y.f90 @@ -0,0 +1,121 @@ +subroutine rcfl_y( im, jm, km, jmax, al, bt, fld, jnx, jmx) + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR a_rcy PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a_rcy copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Recursive filter in y direction +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + use set_knd + use cns_str + use rcfl + use grd_str + implicit none + + INTEGER(i4) :: im, jm, km, jmax + + REAL(r8) :: fld(im,jm,km) + REAL(r8) :: al(im,jmax,km), bt(im,jmax,km) + INTEGER(i4) :: jnx(im,jm,km), jmx(km) + + INTEGER(i4) :: i,j,k, ktr + INTEGER(i4) :: indSupWP + INTEGER nthreads, tid + integer :: OMP_GET_NUM_THREADS, OMP_GET_THREAD_NUM + +tid=1 +!$OMP PARALLEL & +!$OMP PRIVATE(k,j,i,ktr,indSupWP,tid) +!$ tid = OMP_GET_THREAD_NUM()+1 + +!$OMP DO + do k=1,km + + a_rcy(:,:,tid) = 0.0 + b_rcy(:,:,tid) = 0.0 + c_rcy(:,:,tid) = 0.0 + + do j=1,jm + do i=1,im + a_rcy(i,jnx(i,j,k),tid) = fld(i,j,k) + enddo + enddo + alp_rcy(:,:,tid) = al(:,:,k) + bta_rcy(:,:,tid) = bt(:,:,k) + + + do ktr = 1,rcf%ntr + +! positive direction + if( ktr.eq.1 )then + b_rcy(:,1,tid) = (1.-alp_rcy(:,1,tid)) * a_rcy(:,1,tid) + elseif( ktr.eq.2 )then + b_rcy(:,1,tid) = a_rcy(:,1,tid) / (1.+alp_rcy(:,1,tid)) + else + b_rcy(:,1,tid) = (1.-alp_rcy(:,1,tid)) * (a_rcy(:,1,tid)-alp_rcy(:,1,tid)**3 * a_rcy(:,2,tid)) / (1.-alp_rcy(:,1,tid)**2)**2 + endif + + do j=2,jmx(k) + b_rcy(:,j,tid) = alp_rcy(:,j,tid)*b_rcy(:,j-1,tid) + (1.-alp_rcy(:,j,tid))*a_rcy(:,j,tid) + enddo + +! negative direction + if( ktr.eq.1 )then + c_rcy(:,jmx(k),tid) = b_rcy(:,jmx(k),tid) / (1.+bta_rcy(:,jmx(k),tid)) + else + c_rcy(:,jmx(k),tid) = (1.-bta_rcy(:,jmx(k),tid)) * & + (b_rcy(:,jmx(k),tid)-bta_rcy(:,jmx(k),tid)**3 * b_rcy(:,jmx(k)-1,tid)) / (1.-bta_rcy(:,jmx(k),tid)**2)**2 + endif + + do j=jmx(k)-1,1,-1 + c_rcy(:,j,tid) = bta_rcy(:,j,tid)*c_rcy(:,j+1,tid) + (1.-bta_rcy(:,j,tid))*b_rcy(:,j,tid) + enddo + + a_rcy(:,:,tid) = c_rcy(:,:,tid) + + enddo + +! do j=1,jm +! do i=1,im +! fld(i,j,k) = a_rcy(i,jnx(i,j,k)) +! enddo +! enddo + +! This way fills land points with some values. +! We prefer not investigate at the mooment and use only the water points + do indSupWP=1,nSurfaceWaterPoints + i = SurfaceWaterPoints(1,indSupWP) + j = SurfaceWaterPoints(2,indSupWP) + fld(i,j,k) = a_rcy(i,jnx(i,j,k),tid) + enddo + + + + enddo +!$OMP END DO +!$OMP END PARALLEL + + +end subroutine rcfl_y diff --git a/rcfl_y_ad.f90 b/rcfl_y_ad.f90 new file mode 100644 index 0000000..7da2238 --- /dev/null +++ b/rcfl_y_ad.f90 @@ -0,0 +1,131 @@ +subroutine rcfl_y_ad( im, jm, km, jmax, al, bt, fld, jnx, jmx) + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR a_rcy PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a_rcy copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Recursive filter in y direction - adjoint +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + use set_knd + use cns_str + use rcfl + use grd_str + implicit none + + INTEGER(i4) :: im, jm, km, jmax + + REAL(r8) :: fld(im,jm,km) + REAL(r8) :: al(im,jmax,km), bt(im,jmax,km) + INTEGER(i4) :: jnx(im,jm,km), jmx(km) + + + INTEGER(i4) :: i,j,k, ktr + INTEGER(i4) :: indSupWP + INTEGER nthreads, tid + integer :: OMP_GET_NUM_THREADS, OMP_GET_THREAD_NUM + +tid=1 +!$OMP PARALLEL & +!$OMP PRIVATE(k,j,i,ktr,indSupWP,tid) +!$ tid = OMP_GET_THREAD_NUM()+1 + +!$OMP DO + do k=1,km + + a_rcy(:,:,tid) = 0.0 + b_rcy(:,:,tid) = 0.0 + c_rcy(:,:,tid) = 0.0 + + do j=1,jm + do i=1,im + c_rcy(i,jnx(i,j,k),tid) = fld(i,j,k) + enddo + enddo + alp_rcy(:,:,tid) = al(:,:,k) + bta_rcy(:,:,tid) = bt(:,:,k) + + do ktr = 1,rcf%ntr + +! negative direction + b_rcy(:,:,tid) = 0.0 + + do j=1,jmx(k)-1 + c_rcy(:,j+1,tid) = c_rcy(:,j+1,tid) + bta_rcy(:,j,tid)*c_rcy(:,j,tid) + b_rcy(:,j,tid) = (1.-bta_rcy(:,j,tid))*c_rcy(:,j,tid) + enddo + + + if( ktr.eq.1 )then + b_rcy(:,jmx(k),tid) = b_rcy(:,jmx(k),tid) + c_rcy(:,jmx(k),tid) / (1.+bta_rcy(:,jmx(k),tid)) + else + b_rcy(:,jmx(k),tid ) = b_rcy(:,jmx(k),tid ) + (1.-bta_rcy(:,jmx(k),tid)) * c_rcy(:,jmx(k),tid) / (1.-bta_rcy(:,jmx(k),tid)**2)**2 + b_rcy(:,jmx(k)-1,tid) = b_rcy(:,jmx(k)-1,tid) - (1.-bta_rcy(:,jmx(k),tid)) * & + bta_rcy(:,jmx(k),tid)**3 * c_rcy(:,jmx(k),tid) / (1.-bta_rcy(:,jmx(k),tid)**2)**2 + endif + +! positive direction + a_rcy(:,:,tid) = 0.0 + + do j=jmx(k),2,-1 + b_rcy(:,j-1,tid) = b_rcy(:,j-1,tid) + alp_rcy(:,j,tid)*b_rcy(:,j,tid) + a_rcy(:,j,tid) = a_rcy(:,j,tid) + (1.-alp_rcy(:,j,tid))*b_rcy(:,j,tid) + enddo + + + if( ktr.eq.1 )then + a_rcy(:,1,tid) = a_rcy(:,1,tid) + (1.-alp_rcy(:,1,tid)) * b_rcy(:,1,tid) + elseif( ktr.eq.2 )then + a_rcy(:,1,tid) = a_rcy(:,1,tid) + b_rcy(:,1,tid) / (1.+alp_rcy(:,1,tid)) + else + a_rcy(:,1,tid) = a_rcy(:,1,tid) + (1.-alp_rcy(:,1,tid)) * b_rcy(:,1,tid) / (1.-alp_rcy(:,1,tid)**2)**2 + a_rcy(:,2,tid) = a_rcy(:,2,tid) - (1.-alp_rcy(:,1,tid)) * alp_rcy(:,1,tid)**3 * b_rcy(:,1,tid) / (1.-alp_rcy(:,1,tid)**2)**2 + endif + + + c_rcy(:,:,tid) = a_rcy(:,:,tid) + + enddo + +! do j=1,jm +! do i=1,im +! fld(i,j,k) = c_rcy(i,jnx(i,j,k)) +! enddo +! enddo + +! This way fills land points with some values. +! We prefer not investigate at the mooment and use only the water points + do indSupWP=1,nSurfaceWaterPoints + i = SurfaceWaterPoints(1,indSupWP) + j = SurfaceWaterPoints(2,indSupWP) + fld(i,j,k) = c_rcy(i,jnx(i,j,k),tid) + enddo + + + enddo +!$OMP END DO +!$OMP END PARALLEL + + +end subroutine rcfl_y_ad diff --git a/rcfl_y_ad_init.f90 b/rcfl_y_ad_init.f90 new file mode 100644 index 0000000..71701b7 --- /dev/null +++ b/rcfl_y_ad_init.f90 @@ -0,0 +1,115 @@ +subroutine rcfl_y_ad_init( im, jm, km, jmax, al, bt, fld, jnx, jmx) + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Recursive filter in y direction - adjoint +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + use set_knd + use cns_str + + implicit none + + INTEGER(i4) :: im, jm, km, jmax + + REAL(r8) :: fld(im,jm,km) + REAL(r8) :: al(im,jmax,km), bt(im,jmax,km) + INTEGER(i4) :: jnx(im,jm,km), jmx(km) + REAL(r8), allocatable :: a(:,:), b(:,:), c(:,:) + REAL(r8), allocatable :: alp(:,:), bta(:,:) + + INTEGER(i4) :: i,j,k, ktr + + ALLOCATE ( a(im,jmax), b(im,jmax), c(im,jmax) ) + ALLOCATE ( alp(im,jmax), bta(im,jmax) ) + alp = huge(alp(1,1)); bta = huge(bta(1,1)) + do k=1,km + + a(:,:) = 0.0 + b(:,:) = 0.0 + c(:,:) = 0.0 + + do j=1,jm + do i=1,im + c(i,jnx(i,j,k)) = fld(i,j,k) + enddo + enddo + alp(:,:) = al(:,:,k) + bta(:,:) = bt(:,:,k) + + do ktr = 1,rcf%ntr + +! negative direction + b(:,:) = 0.0 + + do j=1,jmx(k)-1 + c(:,j+1) = c(:,j+1) + bta(:,j)*c(:,j) + b(:,j) = (1.-bta(:,j))*c(:,j) + enddo + + + if( ktr.eq.1 )then + b(:,jmx(k)) = b(:,jmx(k)) + c(:,jmx(k)) / (1.+bta(:,jmx(k))) + else + b(:,jmx(k) ) = b(:,jmx(k) ) + (1.-bta(:,jmx(k))) * c(:,jmx(k)) / (1.-bta(:,jmx(k))**2)**2 + b(:,jmx(k)-1) = b(:,jmx(k)-1) - (1.-bta(:,jmx(k))) * bta(:,jmx(k))**3 * c(:,jmx(k)) / (1.-bta(:,jmx(k))**2)**2 + endif + +! positive direction + a(:,:) = 0.0 + + do j=jmx(k),2,-1 + b(:,j-1) = b(:,j-1) + alp(:,j)*b(:,j) + a(:,j) = a(:,j) + (1.-alp(:,j))*b(:,j) + enddo + + + if( ktr.eq.1 )then + a(:,1) = a(:,1) + (1.-alp(:,1)) * b(:,1) + elseif( ktr.eq.2 )then + a(:,1) = a(:,1) + b(:,1) / (1.+alp(:,1)) + else + a(:,1) = a(:,1) + (1.-alp(:,1)) * b(:,1) / (1.-alp(:,1)**2)**2 + a(:,2) = a(:,2) - (1.-alp(:,1)) * alp(:,1)**3 * b(:,1) / (1.-alp(:,1)**2)**2 + endif + + + c(:,:) = a(:,:) + + enddo + + do j=1,jm + do i=1,im + fld(i,j,k) = c(i,jnx(i,j,k)) + enddo + enddo + + enddo + + DEALLOCATE ( a, b, c ) + DEALLOCATE ( alp, bta ) + +end subroutine rcfl_y_ad_init diff --git a/rcfl_y_init.f90 b/rcfl_y_init.f90 new file mode 100644 index 0000000..2017b86 --- /dev/null +++ b/rcfl_y_init.f90 @@ -0,0 +1,106 @@ +subroutine rcfl_y_init( im, jm, km, jmax, al, bt, fld, jnx, jmx) + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Recursive filter in y direction +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + use set_knd + use cns_str + + implicit none + + INTEGER(i4) :: im, jm, km, jmax + + REAL(r8) :: fld(im,jm,km) + REAL(r8) :: al(im,jmax,km), bt(im,jmax,km) + INTEGER(i4) :: jnx(im,jm,km), jmx(km) + REAL(r8), allocatable :: a(:,:), b(:,:), c(:,:) + REAL(r8), allocatable :: alp(:,:), bta(:,:) + + INTEGER(i4) :: i,j,k, ktr + + + ALLOCATE ( a(im,jmax), b(im,jmax), c(im,jmax) ) + ALLOCATE ( alp(im,jmax), bta(im,jmax) ) + alp = huge(alp(1,1)); bta = huge(bta(1,1)) + do k=1,km + + a(:,:) = 0.0 + b(:,:) = 0.0 + c(:,:) = 0.0 + + do j=1,jm + do i=1,im + a(i,jnx(i,j,k)) = fld(i,j,k) + enddo + enddo + alp(:,:) = al(:,:,k) + bta(:,:) = bt(:,:,k) + + + do ktr = 1,rcf%ntr + +! positive direction + if( ktr.eq.1 )then + b(:,1) = (1.-alp(:,1)) * a(:,1) + elseif( ktr.eq.2 )then + b(:,1) = a(:,1) / (1.+alp(:,1)) + else + b(:,1) = (1.-alp(:,1)) * (a(:,1)-alp(:,1)**3 * a(:,2)) / (1.-alp(:,1)**2)**2 + endif + + do j=2,jmx(k) + b(:,j) = alp(:,j)*b(:,j-1) + (1.-alp(:,j))*a(:,j) + enddo + +! negative direction + if( ktr.eq.1 )then + c(:,jmx(k)) = b(:,jmx(k)) / (1.+bta(:,jmx(k))) + else + c(:,jmx(k)) = (1.-bta(:,jmx(k))) * (b(:,jmx(k))-bta(:,jmx(k))**3 * b(:,jmx(k)-1)) / (1.-bta(:,jmx(k))**2)**2 + endif + + do j=jmx(k)-1,1,-1 + c(:,j) = bta(:,j)*c(:,j+1) + (1.-bta(:,j))*b(:,j) + enddo + + a(:,:) = c(:,:) + + enddo + + do j=1,jm + do i=1,im + fld(i,j,k) = a(i,jnx(i,j,k)) + enddo + enddo + + enddo + + DEALLOCATE ( a, b, c ) + DEALLOCATE ( alp, bta ) + +end subroutine rcfl_y_init diff --git a/rdeofs.f90 b/rdeofs.f90 new file mode 100644 index 0000000..0c71e83 --- /dev/null +++ b/rdeofs.f90 @@ -0,0 +1,110 @@ +subroutine rdeofs + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! READ parameters of the MFS_16_72 grid ! +! ! +! Version 1: S.Dobricic 2006 ! +! This routine will have effect only if compiled with netcdf library. ! +!----------------------------------------------------------------------- + + use set_knd + use drv_str + use eof_str + use netcdf + use grd_str + use filenames + + implicit none + + INTEGER(i4) :: stat, ncid, idvar, neofs, nlevs + + + stat = nf90_open(trim(EOF_FILE), NF90_NOWRITE, ncid) + if (stat /= nf90_noerr) call netcdf_err(stat) + +! Get dimensions + stat = nf90_inq_dimid (ncid, 'nreg', idvar) + if (stat /= nf90_noerr) call netcdf_err(stat) + stat = nf90_inquire_dimension (ncid, idvar, len = ros%nreg) + if (stat /= nf90_noerr) call netcdf_err(stat) + stat = nf90_inq_dimid (ncid, 'nlev', idvar) + if (stat /= nf90_noerr) call netcdf_err(stat) + stat = nf90_inquire_dimension (ncid, idvar, len = nlevs) + if (stat /= nf90_noerr) call netcdf_err(stat) + stat = nf90_inq_dimid (ncid, 'neof', idvar) + if (stat /= nf90_noerr) call netcdf_err(stat) + stat = nf90_inquire_dimension (ncid, idvar, len = neofs) + if (stat /= nf90_noerr) call netcdf_err(stat) + + write(drv%dia,*)'Eof dimensions are: ',ros%nreg, ros%kmt, neofs + write(drv%dia,*)'Uses ',ros%neof,' eofs.' + + if(ros%neof .gt. neofs) then + write(drv%dia,*)'Error: Requires more Eofs than available in the input file.' + !stop + call f_exit(22) + endif + if(ros%kmt .ne. nlevs) then + write(drv%dia,*)'Error: Vertical dimension different than in the input file.' + !stop + call f_exit(23) + endif + +! Allocate eof arrays + ALLOCATE ( ros%evc( ros%nreg, ros%kmt, neofs)) ; ros%evc = huge(ros%evc(1,1,1)) + ALLOCATE (ros%eva( ros%nreg, neofs) ) ; ros%eva = huge(ros%eva(1,1)) + ALLOCATE ( ros%cor( ros%nreg, ros%neof, neofs) ) ; ros%cor = huge(ros%cor(1,1,1)) + + stat = nf90_inq_varid (ncid, 'eva', idvar) + if (stat /= nf90_noerr) call netcdf_err(stat) + stat = nf90_get_var (ncid,idvar,ros%eva) + if (stat /= nf90_noerr) call netcdf_err(stat) + stat = nf90_inq_varid (ncid, 'evc', idvar) + if (stat /= nf90_noerr) call netcdf_err(stat) + stat = nf90_get_var (ncid,idvar,ros%evc) + if (stat /= nf90_noerr) call netcdf_err(stat) + + stat = nf90_close(ncid) + +! ros%eva(:,:) = 0.1 +! ros%evc(:,:,:,:) = 0.1 + + +! do nec=1,ros%neof +! do k=1,ros%neof +! do nrg=1,ros%nreg +! if(k.eq.nec)then +!! ros%cor(nrg,k,nec) = ros%eva(nrg,nec) +! else +!! ros%cor(nrg,k,nec) = 0.0 +! endif +! enddo +! enddo +! enddo + + +end subroutine rdeofs + + diff --git a/rdgrds.f90 b/rdgrds.f90 new file mode 100644 index 0000000..c4496c5 --- /dev/null +++ b/rdgrds.f90 @@ -0,0 +1,192 @@ +subroutine rdgrd + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! READ parameters of the MFS_16_72 grid ! +! ! +! Version 1: S.Dobricic 2006 ! +! This routine will have effect only if compiled with netcdf library. ! +!----------------------------------------------------------------------- + + use set_knd + use drv_str + use grd_str + use netcdf + use filenames + + implicit none + + INTEGER(i4) :: stat, ncid, idvar + real(r4), ALLOCATABLE :: x3(:,:,:), x2(:,:), x1(:) + + character :: cgrd + + write(cgrd,'(i1)') grd%grd_mod + +! Vertical levels ------------------------------------------------ + stat = nf90_open(GRID_FILE, NF90_NOWRITE, ncid) + if (stat /= nf90_noerr) call netcdf_err(stat) + + +! Get dimensions + stat = nf90_inq_dimid (ncid, 'im', idvar) + if (stat /= nf90_noerr) call netcdf_err(stat) + stat = nf90_inquire_dimension (ncid, idvar, len = grd%im) + if (stat /= nf90_noerr) call netcdf_err(stat) + stat = nf90_inq_dimid (ncid, 'jm', idvar) + if (stat /= nf90_noerr) call netcdf_err(stat) + stat = nf90_inquire_dimension (ncid, idvar, len = grd%jm) + if (stat /= nf90_noerr) call netcdf_err(stat) + stat = nf90_inq_dimid (ncid, 'km', idvar) + if (stat /= nf90_noerr) call netcdf_err(stat) + stat = nf90_inquire_dimension (ncid, idvar, len = grd%km) + if (stat /= nf90_noerr) call netcdf_err(stat) + + write(drv%dia,*)'Grid dimensions are: ',grd%im,grd%jm,grd%km + +! Allocate grid arrays + ALLOCATE ( grd%reg(grd%im,grd%jm)) ; grd%reg = huge(grd%reg(1,1)) + ALLOCATE ( grd%msk(grd%im,grd%jm,grd%km)) ; grd%msk = huge(grd%msk(1,1,1)) + ALLOCATE ( grd%ums(grd%im,grd%jm,grd%km), grd%vms(grd%im,grd%jm,grd%km)) + grd%ums = huge(grd%ums(1,1,1)) ; grd%vms = huge(grd%vms(1,1,1)) + ALLOCATE ( grd%f(grd%im,grd%jm)) ; grd%f = huge(grd%f(1,1)); + + + if (drv%bphy.eq.1) then + ALLOCATE ( grd%tem(grd%im,grd%jm,grd%km), grd%sal(grd%im,grd%jm,grd%km)) + ALLOCATE ( grd%uvl(grd%im,grd%jm,grd%km), grd%vvl(grd%im,grd%jm,grd%km)) + ALLOCATE ( grd%uvl_ad(grd%im,grd%jm,grd%km), grd%vvl_ad(grd%im,grd%jm,grd%km)) + ALLOCATE ( grd%b_x(grd%im,grd%jm,grd%km), grd%b_y(grd%im,grd%jm,grd%km)) + ALLOCATE ( grd%temb(grd%im,grd%jm,grd%km), grd%salb(grd%im,grd%jm,grd%km)) + ALLOCATE ( grd%tem_ad(grd%im,grd%jm,grd%km), grd%sal_ad(grd%im,grd%jm,grd%km)) + + ALLOCATE ( grd%dns(grd%im,grd%jm,grd%km)) + ALLOCATE ( grd%eta(grd%im,grd%jm)) + ALLOCATE ( grd%etab(grd%im,grd%jm)) + ALLOCATE ( grd%sla(grd%im,grd%jm)) + ALLOCATE ( grd%eta_ad(grd%im,grd%jm)) + + + endif + ALLOCATE ( grd%mdt(grd%im,grd%jm)) ; grd%mdt = huge(grd%mdt(1,1)); + ALLOCATE ( grd%hgt(grd%im,grd%jm)) ; grd%hgt = huge(grd%hgt(1,1)) + ALLOCATE ( grd%bx(grd%im,grd%jm)) ; grd%bx = huge(grd%bx(1,1)) + ALLOCATE ( grd%by(grd%im,grd%jm)) ; grd%by = huge(grd%by(1,1)) + ALLOCATE ( grd%lon(grd%im,grd%jm)) ; grd%lon = huge(grd%lon(1,1)) + ALLOCATE ( grd%lat(grd%im,grd%jm)) ; grd%lat = huge(grd%lat(1,1)) + ALLOCATE ( grd%dep(grd%km)) ; grd%dep = huge(grd%dep(1)) + ALLOCATE ( grd%dx(grd%im,grd%jm)) ; grd%dx = huge(grd%dx(1,1)) + ALLOCATE ( grd%dy(grd%im,grd%jm)) ; grd%dy = huge(grd%dy(1,1)) + ALLOCATE ( grd%dz(grd%km)) ; grd%dz = huge(grd%dz(1)) + + ALLOCATE ( grd%dxdy(grd%im,grd%jm)) ; grd%dxdy = huge(grd%dxdy(1,1)) + ALLOCATE ( grd%alx(grd%im,grd%jm) ) ; grd%alx = huge(grd%alx(1,1)) + ALLOCATE ( grd%aly(grd%im,grd%jm) ) ; grd%aly = huge(grd%aly(1,1)) + ALLOCATE ( grd%btx(grd%im,grd%jm) ) ; grd%btx = huge(grd%btx(1,1)) + ALLOCATE ( grd%bty(grd%im,grd%jm) ) ; grd%bty = huge(grd%bty(1,1)) + ALLOCATE ( grd%scx(grd%im,grd%jm) ) ; grd%scx = huge(grd%scx(1,1)) + ALLOCATE ( grd%scy(grd%im,grd%jm) ) ; grd%scy = huge(grd%scy(1,1)) + ALLOCATE ( grd%msr(grd%im,grd%jm,grd%km) ) ; grd%msr = huge(grd%msr(1,1,1)) + ALLOCATE ( grd%imx(grd%km)) ; grd%imx = huge(grd%imx(1)) + ALLOCATE ( grd%jmx(grd%km)) ; grd%jmx = huge(grd%jmx(1)) + ALLOCATE ( grd%istp(grd%im,grd%jm)) ; grd%istp = huge(grd%istp(1,1)) + ALLOCATE ( grd%jstp(grd%im,grd%jm)) ; grd%jstp = huge(grd%jstp(1,1)) + ALLOCATE ( grd%inx(grd%im,grd%jm,grd%km)) ; grd%inx = huge(grd%inx(1,1,1)) + ALLOCATE ( grd%jnx(grd%im,grd%jm,grd%km)) ; grd%jnx = huge(grd%jnx(1,1,1)) + ALLOCATE ( grd%fct(grd%im,grd%jm,grd%km) ) ; grd%fct = huge(grd%fct(1,1,1)) + + ALLOCATE ( Dump_chl(grd%im,grd%jm,grd%km) ) ; Dump_chl = 0.0 + ALLOCATE ( Dump_msk(grd%im,grd%jm) ) ; Dump_msk = 0.0 + if(drv%biol.eq.1) then + ALLOCATE ( grd%chl(grd%im,grd%jm,grd%km,grd%nchl) ) ; grd%chl = huge(grd%chl(1,1,1,1)) + ALLOCATE ( grd%chl_ad(grd%im,grd%jm,grd%km,grd%nchl) ) ; grd%chl_ad = huge(grd%chl_ad(1,1,1,1)) + endif + + ALLOCATE ( x3(grd%im,grd%jm,grd%km)) ; x3 = huge(x3(1,1,1)) + ALLOCATE ( x2(grd%im,grd%jm)) ; x2 = huge(x2(1,1)) + ALLOCATE ( x1(grd%km) ) ; x1 = huge(x1(1)) + + + + + stat = nf90_inq_varid (ncid, 'lon', idvar) + if (stat /= nf90_noerr) call netcdf_err(stat) + stat = nf90_get_var (ncid,idvar,grd%lon) + if (stat /= nf90_noerr) call netcdf_err(stat) + stat = nf90_inq_varid (ncid, 'lat', idvar) + if (stat /= nf90_noerr) call netcdf_err(stat) + stat = nf90_get_var (ncid,idvar,grd%lat) + if (stat /= nf90_noerr) call netcdf_err(stat) + stat = nf90_inq_varid (ncid, 'dx', idvar) + if (stat /= nf90_noerr) call netcdf_err(stat) + stat = nf90_get_var (ncid,idvar,grd%dx) + if (stat /= nf90_noerr) call netcdf_err(stat) + stat = nf90_inq_varid (ncid, 'dy', idvar) + if (stat /= nf90_noerr) call netcdf_err(stat) + stat = nf90_get_var (ncid,idvar,grd%dy) + if (stat /= nf90_noerr) call netcdf_err(stat) + stat = nf90_inq_varid (ncid, 'dz', idvar) + if (stat /= nf90_noerr) call netcdf_err(stat) + stat = nf90_get_var (ncid,idvar,grd%dz) + if (stat /= nf90_noerr) call netcdf_err(stat) + + stat = nf90_inq_varid (ncid, 'dep', idvar) + if (stat /= nf90_noerr) call netcdf_err(stat) + stat = nf90_get_var (ncid, idvar, x1) + if (stat /= nf90_noerr) call netcdf_err(stat) + grd%dep(:) = x1(:) + + stat = nf90_inq_varid (ncid, 'topo', idvar) + if (stat /= nf90_noerr) call netcdf_err(stat) + stat = nf90_get_var (ncid,idvar,x2) + if (stat /= nf90_noerr) call netcdf_err(stat) + grd%hgt(:,:) = x2(:,:) + + stat = nf90_inq_varid (ncid, 'tmsk', idvar) + if (stat /= nf90_noerr) call netcdf_err(stat) + stat = nf90_get_var (ncid,idvar,x3) + if (stat /= nf90_noerr) call netcdf_err(stat) + grd%msk(:,:,:) = x3(:,:,:) + + stat = nf90_inq_varid (ncid, 'regs', idvar) + if (stat /= nf90_noerr) call netcdf_err(stat) + stat = nf90_get_var (ncid, idvar, x2) + if (stat /= nf90_noerr) call netcdf_err(stat) + grd%reg(:,:) = int(x2(:,:)) + + stat = nf90_inq_varid (ncid, 'mdt', idvar) + if (stat /= nf90_noerr) call netcdf_err(stat) + stat = nf90_get_var (ncid, idvar, x2) + grd%mdt(:,:) = x2(:,:) + if (stat /= nf90_noerr) call netcdf_err(stat) + + stat = nf90_close(ncid) + +! ---------------------------------------------------------------- + + DEALLOCATE ( x3, x2, x1 ) + +end subroutine rdgrd + + diff --git a/res_inc.f90 b/res_inc.f90 new file mode 100644 index 0000000..57a91d8 --- /dev/null +++ b/res_inc.f90 @@ -0,0 +1,56 @@ +subroutine res_inc + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Initialise for adjoint calculations ! +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + + use set_knd + use drv_str + use grd_str + use obs_str + use bmd_str + + implicit none + + if(drv%biol.eq.0 .or. drv%bphy.eq.1)then + grd%eta_ad(:,: ) = 0.0 + grd%tem_ad(:,:,:) = 0.0 + grd%sal_ad(:,:,:) = 0.0 + grd%uvl_ad(:,:,:) = 0.0 + grd%vvl_ad(:,:,:) = 0.0 + + grd%b_x(:,:,:) = 0.0 + grd%b_y(:,:,:) = 0.0 + endif + if(drv%biol.eq.1) then + grd%chl_ad(:,:,:,:) = 0.0 ! OMP + endif + + obs%gra(:) = obs%amo(:) / obs%err(:) ! OMP + +end subroutine res_inc diff --git a/resid.f90 b/resid.f90 new file mode 100644 index 0000000..b06eb1e --- /dev/null +++ b/resid.f90 @@ -0,0 +1,145 @@ +subroutine resid + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Calculate analysis - observation ! +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + + use set_knd + use obs_str + + implicit none + + INTEGER(i4) :: i, k + + k = 0 + +! --- +! Satellite observations of SLA + do i=1,sla%no + if(sla%flc(i).eq.1)then + k = k + 1 + obs%inc(k) = sla%inc(i) + obs%amo(k) = ( obs%inc(k) - obs%res(k) ) / obs%err(k) + endif + enddo + +! --- +! ARGO observations + do i=1,arg%no + if(arg%flc(i).eq.1)then + k = k + 1 + obs%inc(k) = arg%inc(i) + obs%amo(k) = ( obs%inc(k) - obs%res(k) ) / obs%err(k) + endif + enddo + +! --- +! XBT observations + do i=1,xbt%no + if(xbt%flc(i).eq.1)then + k = k + 1 + obs%inc(k) = xbt%inc(i) + obs%amo(k) = ( obs%inc(k) - obs%res(k) ) / obs%err(k) + endif + enddo + +! --- +! Glider observations + do i=1,gld%no + if(gld%flc(i).eq.1)then + k = k + 1 + obs%inc(k) = gld%inc(i) + obs%amo(k) = ( obs%inc(k) - obs%res(k) ) / obs%err(k) + endif + enddo + +! --- +! Observations of Argo float positions + do i=1,tra%no + if(tra%flc(i).eq.1)then + k = k + 1 + obs%inc(k) = tra%inx(i) + obs%amo(k) = ( obs%inc(k) - obs%res(k) ) / obs%err(k) + endif + enddo + do i=1,tra%no + if(tra%flc(i).eq.1)then + k = k + 1 + obs%inc(k) = tra%iny(i) + obs%amo(k) = ( obs%inc(k) - obs%res(k) ) / obs%err(k) + endif + enddo + +! --- +! Observations of positions of surface drifters + do i=1,trd%no + if(trd%flc(i).eq.1)then + k = k + 1 + obs%inc(k) = trd%inx(i) + obs%amo(k) = ( obs%inc(k) - obs%res(k) ) / obs%err(k) + endif + enddo + do i=1,trd%no + if(trd%flc(i).eq.1)then + k = k + 1 + obs%inc(k) = trd%iny(i) + obs%amo(k) = ( obs%inc(k) - obs%res(k) ) / obs%err(k) + endif + enddo + +! --- +! Observations of velocity by drifters + do i=1,vdr%no + if(vdr%flc(i).eq.1)then + k = k + 1 + obs%inc(k) = vdr%inc(i) + obs%amo(k) = ( obs%inc(k) - obs%res(k) ) / obs%err(k) + endif + enddo + +! --- +! Observations of velocity by gliders + do i=1,gvl%no + if(gvl%flc(i).eq.1)then + k = k + 1 + obs%inc(k) = gvl%inc(i) + obs%amo(k) = ( obs%inc(k) - obs%res(k) ) / obs%err(k) + endif + enddo + +! --- +! Observations of chlorophyll + do i=1,chl%no + if(chl%flc(i).eq.1)then + k = k + 1 + obs%inc(k) = chl%inc(i) + obs%amo(k) = ( obs%inc(k) - obs%res(k) ) / obs%err(k) + endif + enddo + +end subroutine resid diff --git a/routines.f b/routines.f new file mode 100644 index 0000000..e4d56d8 --- /dev/null +++ b/routines.f @@ -0,0 +1,4471 @@ +c================ L-BFGS-B (version 2.1) ========================== + +! subroutine setulb(n, m, x, l, u, nbd, f, g, factr, pgtol, wa, iwa, +! + task, iprint, csave, lsave, isave, dsave) + subroutine setulb(n, m, x, l, u, nbd, f, g, factr, pgtol, + + ws, wy, + + sy, ss, wt, wn, snd, z, r, d, t, wa, + + iwa, + + task, iprint, csave, lsave, isave, dsave) +!anna +! + task, iprint, csave, lsave, isave, dsave,iter) +!anna + + character(LEN=60) task, csave + logical lsave(4) + integer n, m, iprint, +! integer n, m, iprint,iter +!anna + + nbd(n), iwa(3*n), isave(44) + real(8) f, factr, pgtol, x(n), l(n), u(n), g(n),dsave(29) +! + ,wa(2*m*n+4*n+12*m*m+12*m) + real(8)wa(8*m), + + ws(n, m), wy(n, m), sy(m, m), ss(m, m), + + wt(m, m), wn(2*m, 2*m), snd(2*m, 2*m), + + z(n), r(n), d(n), t(n) + +c ************ +c +c Subroutine setulb +c +c This subroutine partitions the working arrays wa and iwa, and +c then uses the limited memory BFGS method to solve the bound +c constrained optimization problem by calling mainlb. +c (The direct method will be used in the subspace minimization.) +c +c n is an integer variable. +c On entry n is the dimension of the problem. +c On exit n is unchanged. +c +c m is an integer variable. +c On entry m is the maximum number of variable metric corrections +c used to define the limited memory matrix. +c On exit m is unchanged. +c +c x is a real(8)array of dimension n. +c On entry x is an approximation to the solution. +c On exit x is the current approximation. +c +c l is a real(8)array of dimension n. +c On entry l is the lower bound on x. +c On exit l is unchanged. +c +c u is a real(8)array of dimension n. +c On entry u is the upper bound on x. +c On exit u is unchanged. +c +c nbd is an integer array of dimension n. +c On entry nbd represents the type of bounds imposed on the +c variables, and must be specified as follows: +c nbd(i)=0 if x(i) is unbounded, +c 1 if x(i) has only a lower bound, +c 2 if x(i) has both lower and upper bounds, and +c 3 if x(i) has only an upper bound. +c On exit nbd is unchanged. +c +c f is a real(8)variable. +c On first entry f is unspecified. +c On final exit f is the value of the function at x. +c +c g is a real(8)array of dimension n. +c On first entry g is unspecified. +c On final exit g is the value of the gradient at x. +c +c factr is a real(8)variable. +c On entry factr >= 0 is specified by the user. The iteration +c will stop when +c +c (f^k - f^{k+1})/max{|f^k|,|f^{k+1}|,1} <= factr*epsmch +c +c where epsmch is the machine precision, which is automatically +c generated by the code. Typical values for factr: 1.d+12 for +c low accuracy; 1.d+7 for moderate accuracy; 1.d+1 for extremely +c high accuracy. +c On exit factr is unchanged. +c +c pgtol is a real(8)variable. +c On entry pgtol >= 0 is specified by the user. The iteration +c will stop when +c +c max{|proj g_i | i = 1, ..., n} <= pgtol +c +c where pg_i is the ith component of the projected gradient. +c On exit pgtol is unchanged. +c +c wa is a real(8)working array of length +c (2mmax + 4)nmax + 12mmax^2 + 12mmax. +c +c iwa is an integer working array of length 3nmax. +c +c task is a working string of characters of length 60 indicating +c the current job when entering and quitting this subroutine. +c +c iprint is an integer variable that must be set by the user. +c It controls the frequency and type of output generated: +c iprint<0 no output is generated; +c iprint=0 print only one line at the last iteration; +c 0100 print details of every iteration including x and g; +c When iprint > 0, the file iterate.dat will be created to +c summarize the iteration. +c +c csave is a working string of characters of length 60. +c +c lsave is a logical working array of dimension 4. +c On exit with 'task' = NEW_X, the following information is +c available: +c If lsave(1) = .true. then the initial X has been replaced by +c its projection in the feasible set; +c If lsave(2) = .true. then the problem is constrained; +c If lsave(3) = .true. then each variable has upper and lower +c bounds; +c +c isave is an integer working array of dimension 44. +c On exit with 'task' = NEW_X, the following information is +c available: +c isave(22) = the total number of intervals explored in the +c search of Cauchy points; +c isave(26) = the total number of skipped BFGS updates before +c the current iteration; +c isave(30) = the number of current iteration; +c isave(31) = the total number of BFGS updates prior the current +c iteration; +c isave(33) = the number of intervals explored in the search of +c Cauchy point in the current iteration; +c isave(34) = the total number of function and gradient +c evaluations; +c isave(36) = the number of function value or gradient +c evaluations in the current iteration; +c if isave(37) = 0 then the subspace argmin is within the box; +c if isave(37) = 1 then the subspace argmin is beyond the box; +c isave(38) = the number of free variables in the current +c iteration; +c isave(39) = the number of active constraints in the current +c iteration; +c n + 1 - isave(40) = the number of variables leaving the set of +c active constraints in the current iteration; +c isave(41) = the number of variables entering the set of active +c constraints in the current iteration. +c +c dsave is a real(8)working array of dimension 29. +c On exit with 'task' = NEW_X, the following information is +c available: +c dsave(1) = current 'theta' in the BFGS matrix; +c dsave(2) = f(x) in the previous iteration; +c dsave(3) = factr*epsmch; +c dsave(4) = 2-norm of the line search direction vector; +c dsave(5) = the machine precision epsmch generated by the code; +c dsave(7) = the accumulated time spent on searching for +c Cauchy points; +c dsave(8) = the accumulated time spent on +c subspace minimization; +c dsave(9) = the accumulated time spent on line search; +c dsave(11) = the slope of the line search function at +c the current point of line search; +c dsave(12) = the maximum relative step length imposed in +c line search; +c dsave(13) = the infinity norm of the projected gradient; +c dsave(14) = the relative step length in the line search; +c dsave(15) = the slope of the line search function at +c the starting point of the line search; +c dsave(16) = the square of the 2-norm of the line search +c direction vector. +c +c Subprograms called: +c +c L-BFGS-B Library ... mainlb. +c +c +c References: +c +c [1] R. H. Byrd, P. Lu, J. Nocedal and C. Zhu, ``A limited +c memory algorithm for bound constrained optimization'', +c SIAM J. Scientific Computing 16 (1995), no. 5, pp. 1190--1208. +c +c [2] C. Zhu, R.H. Byrd, P. Lu, J. Nocedal, ``L-BFGS-B: a +c limited memory FORTRAN code for solving bound constrained +c optimization problems'', Tech. Report, NAM-11, EECS Department, +c Northwestern University, 1994. +c +c (Postscript files of these papers are available via anonymous +c ftp to eecs.nwu.edu in the directory pub/lbfgs/lbfgs_bcm.) +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer l1,l2,l3,lws,lr,lz,lt,ld,lsg,lwa,lyg, + + lsgo,lwy,lsy,lss,lyy,lwt,lwn,lsnd,lygo + + if (task .eq. 'START') then + isave(1) = m*n + isave(2) = m**2 + isave(3) = 4*m**2 + isave(4) = 1 + isave(5) = isave(4) + isave(1) + isave(6) = isave(5) + isave(1) + isave(7) = isave(6) + isave(2) + isave(8) = isave(7) + isave(2) + isave(9) = isave(8) + isave(2) + isave(10) = isave(9) + isave(2) + isave(11) = isave(10) + isave(3) + isave(12) = isave(11) + isave(3) + isave(13) = isave(12) + n + isave(14) = isave(13) + n + isave(15) = isave(14) + n + isave(16) = isave(15) + n + isave(17) = isave(16) + 8*m + isave(18) = isave(17) + m + isave(19) = isave(18) + m + isave(20) = isave(19) + m + endif + l1 = isave(1) + l2 = isave(2) + l3 = isave(3) + lws = isave(4) + lwy = isave(5) + lsy = isave(6) + lss = isave(7) + lyy = isave(8) + lwt = isave(9) + lwn = isave(10) + lsnd = isave(11) + lz = isave(12) + lr = isave(13) + ld = isave(14) + lt = isave(15) + lwa = isave(16) + lsg = isave(17) + lsgo = isave(18) + lyg = isave(19) + lygo = isave(20) + +! call mainlb(n,m,x,l,u,nbd,f,g,factr,pgtol, +! + wa(lws),wa(lwy),wa(lsy),wa(lss),wa(lyy),wa(lwt), +! + wa(lwn),wa(lsnd),wa(lz),wa(lr),wa(ld),wa(lt), +! + wa(lwa),wa(lsg),wa(lsgo),wa(lyg),wa(lygo), +! + iwa(1),iwa(n+1),iwa(2*n+1),task,iprint, +! + csave,lsave,isave(22),dsave) + call mainlb(n, m, x, l, u, nbd, f, g, factr, pgtol, + + ws, wy, + + sy, ss, wt, wn, snd, z, r, d, t, wa, + + iwa(1),iwa(n+1),iwa(2*n+1),task, + + iprint, csave, lsave, isave(22), dsave) +! + iprint, csave, lsave, isave(22), dsave,iter) +!anna + return + + end + +c======================= The end of setulb ============================= + + subroutine mainlb(n, m, x, l, u, nbd, f, g, factr, pgtol, ws, wy, + + sy, ss, wt, wn, snd, z, r, d, t, wa, + + index, iwhere, indx2, task, + + iprint, csave, lsave, isave, dsave) +! + iprint, csave, lsave, isave, dsave,iter) +!anna + character(LEN=60) task, csave + logical lsave(4) + integer n, m, iprint, nbd(n), index(n), + + iwhere(n), indx2(n), isave(23) + real(8)f, factr, pgtol, + + x(n), l(n), u(n), g(n), z(n), r(n), d(n), t(n), + + wa(8*m), + + ws(n, m), wy(n, m), sy(m, m), ss(m, m), + + wt(m, m), wn(2*m, 2*m), snd(2*m, 2*m), dsave(29) + +c ************ +c +c Subroutine mainlb +c +c This subroutine solves bound constrained optimization problems by +c using the compact formula of the limited memory BFGS updates. +c +c n is an integer variable. +c On entry n is the number of variables. +c On exit n is unchanged. +c +c m is an integer variable. +c On entry m is the maximum number of variable metric +c corrections allowed in the limited memory matrix. +c On exit m is unchanged. +c +c x is a real(8)array of dimension n. +c On entry x is an approximation to the solution. +c On exit x is the current approximation. +c +c l is a real(8)array of dimension n. +c On entry l is the lower bound of x. +c On exit l is unchanged. +c +c u is a real(8)array of dimension n. +c On entry u is the upper bound of x. +c On exit u is unchanged. +c +c nbd is an integer array of dimension n. +c On entry nbd represents the type of bounds imposed on the +c variables, and must be specified as follows: +c nbd(i)=0 if x(i) is unbounded, +c 1 if x(i) has only a lower bound, +c 2 if x(i) has both lower and upper bounds, +c 3 if x(i) has only an upper bound. +c On exit nbd is unchanged. +c +c f is a real(8)variable. +c On first entry f is unspecified. +c On final exit f is the value of the function at x. +c +c g is a real(8)array of dimension n. +c On first entry g is unspecified. +c On final exit g is the value of the gradient at x. +c +c factr is a real(8)variable. +c On entry factr >= 0 is specified by the user. The iteration +c will stop when +c +c (f^k - f^{k+1})/max{|f^k|,|f^{k+1}|,1} <= factr*epsmch +c +c where epsmch is the machine precision, which is automatically +c generated by the code. +c On exit factr is unchanged. +c +c pgtol is a real(8)variable. +c On entry pgtol >= 0 is specified by the user. The iteration +c will stop when +c +c max{|proj g_i | i = 1, ..., n} <= pgtol +c +c where pg_i is the ith component of the projected gradient. +c On exit pgtol is unchanged. +c +c ws, wy, sy, and wt are real(8)working arrays used to +c store the following information defining the limited memory +c BFGS matrix: +c ws, of dimension n x m, stores S, the matrix of s-vectors; +c wy, of dimension n x m, stores Y, the matrix of y-vectors; +c sy, of dimension m x m, stores S'Y; +c ss, of dimension m x m, stores S'S; +c yy, of dimension m x m, stores Y'Y; +c wt, of dimension m x m, stores the Cholesky factorization +c of (theta*S'S+LD^(-1)L'); see eq. +c (2.26) in [3]. +c +c wn is a real(8)working array of dimension 2m x 2m +c used to store the LEL^T factorization of the indefinite matrix +c K = [-D -Y'ZZ'Y/theta L_a'-R_z' ] +c [L_a -R_z theta*S'AA'S ] +c +c where E = [-I 0] +c [ 0 I] +c +c snd is a real(8)working array of dimension 2m x 2m +c used to store the lower triangular part of +c N = [Y' ZZ'Y L_a'+R_z'] +c [L_a +R_z S'AA'S ] +c +c z(n),r(n),d(n),t(n),wa(8*m) are real(8)working arrays. +c z is used at different times to store the Cauchy point and +c the Newton point. +c +c sg(m),sgo(m),yg(m),ygo(m) are real(8)working arrays. +c +c index is an integer working array of dimension n. +c In subroutine freev, index is used to store the free and fixed +c variables at the Generalized Cauchy Point (GCP). +c +c iwhere is an integer working array of dimension n used to record +c the status of the vector x for GCP computation. +c iwhere(i)=0 or -3 if x(i) is free and has bounds, +c 1 if x(i) is fixed at l(i), and l(i) .ne. u(i) +c 2 if x(i) is fixed at u(i), and u(i) .ne. l(i) +c 3 if x(i) is always fixed, i.e., u(i)=x(i)=l(i) +c -1 if x(i) is always free, i.e., no bounds on it. +c +c indx2 is an integer working array of dimension n. +c Within subroutine cauchy, indx2 corresponds to the array iorder. +c In subroutine freev, a list of variables entering and leaving +c the free set is stored in indx2, and it is passed on to +c subroutine formk with this information. +c +c task is a working string of characters of length 60 indicating +c the current job when entering and leaving this subroutine. +c +c iprint is an INTEGER variable that must be set by the user. +c It controls the frequency and type of output generated: +c iprint<0 no output is generated; +c iprint=0 print only one line at the last iteration; +c 0100 print details of every iteration including x and g; +c When iprint > 0, the file iterate.dat will be created to +c summarize the iteration. +c +c csave is a working string of characters of length 60. +c +c lsave is a logical working array of dimension 4. +c +c isave is an integer working array of dimension 23. +c +c dsave is a real(8)working array of dimension 29. +c +c +c Subprograms called +c +c L-BFGS-B Library ... cauchy, subsm, lnsrlb, formk, +c +c errclb, prn1lb, prn2lb, prn3lb, active, projgr, +c +c freev, cmprlb, matupd, formt. +c +c Minpack2 Library ... timer, dpmeps. +c +c Linpack Library ... dcopy, ddot. +c +c +c References: +c +c [1] R. H. Byrd, P. Lu, J. Nocedal and C. Zhu, ``A limited +c memory algorithm for bound constrained optimization'', +c SIAM J. Scientific Computing 16 (1995), no. 5, pp. 1190--1208. +c +c [2] C. Zhu, R.H. Byrd, P. Lu, J. Nocedal, ``L-BFGS-B: FORTRAN +c Subroutines for Large Scale Bound Constrained Optimization'' +c Tech. Report, NAM-11, EECS Department, Northwestern University, +c 1994. +c +c [3] R. Byrd, J. Nocedal and R. Schnabel "Representations of +c Quasi-Newton Matrices and their use in Limited Memory Methods'', +c Mathematical Programming 63 (1994), no. 4, pp. 129-156. +c +c (Postscript files of these papers are available via anonymous +c ftp to eecs.nwu.edu in the directory pub/lbfgs/lbfgs_bcm.) +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + logical prjctd,cnstnd,boxed,updatd,wrk + character(LEN=3) word + integer i,k,nintol,itfile,iback,nskip, + + head,col,iter,itail,iupdat, + + nint,nfgv,info,ifun, + + iword,nfree,nact,ileave,nenter + real(8)theta,fold,ddot,dr,rr,tol,dpmeps, + + xstep,sbgnrm,ddum,dnorm,dtd,epsmch, + + cpu1,cpu2,cachyt,sbtime,lnscht,time1,time2, + + gd,gdold,stp,stpmx,time + real(8)one,zero + parameter (one=1.0d0,zero=0.0d0) + iback = 0 + itail = 0 + ifun = 0 + iword = 0 + nact = 0 + ileave = 0 + nenter = 0 + fold = 0.0 + dnorm = 0.0 + cpu1 = 0.0 + gd = 0.0 + stpmx = 0.0 + sbgnrm = 0.0 + stp = 0.0 + gdold = 0.0 + dtd = 0.0 + if (task .eq. 'START') then + + call timer(time1) + +c Generate the current machine precision. + + epsmch = 1.0E-16 !dpmeps() + +c Initialize counters and scalars when task='START'. + +c for the limited memory BFGS matrices: + col = 0 + head = 1 + theta = one + iupdat = 0 + updatd = .false. + +c for operation counts: + iter = 0 + nfgv = 0 + nint = 0 + nintol = 0 + nskip = 0 + nfree = n + +c for stopping tolerance: + tol = factr*epsmch + +c for measuring running time: + cachyt = 0 + sbtime = 0 + lnscht = 0 + +c 'word' records the status of subspace solutions. + word = '---' + +c 'info' records the termination information. + info = 0 + + if (iprint .ge. 1) then +c open a summary file 'iterate.dat' + open (8, file = 'iterate.dat', status = 'unknown') + itfile = 8 + endif + +c Check the input arguments for errors. + + call errclb(n,m,factr,l,u,nbd,task,info,k) + if (task(1:5) .eq. 'ERROR') then + call prn3lb(n,x,f,task,iprint,info,itfile, + + iter,nfgv,nintol,nskip,nact,sbgnrm, + + zero,nint,word,iback,stp,xstep,k, + + cachyt,sbtime,lnscht) + return + endif + + call prn1lb(n,m,l,u,x,iprint,itfile,epsmch) + +c Initialize iwhere & project x onto the feasible set. + + call active(n,l,u,nbd,x,iwhere,iprint,prjctd,cnstnd,boxed) + +c The end of the initialization. + + else +c restore local variables. + + prjctd = lsave(1) + cnstnd = lsave(2) + boxed = lsave(3) + updatd = lsave(4) + + nintol = isave(1) + itfile = isave(3) + iback = isave(4) + nskip = isave(5) + head = isave(6) + col = isave(7) + itail = isave(8) + iter = isave(9) + iupdat = isave(10) + nint = isave(12) + nfgv = isave(13) + info = isave(14) + ifun = isave(15) + iword = isave(16) + nfree = isave(17) + nact = isave(18) + ileave = isave(19) + nenter = isave(20) + + theta = dsave(1) + fold = dsave(2) + tol = dsave(3) + dnorm = dsave(4) + epsmch = dsave(5) + cpu1 = dsave(6) + cachyt = dsave(7) + sbtime = dsave(8) + lnscht = dsave(9) + time1 = dsave(10) + gd = dsave(11) + stpmx = dsave(12) + sbgnrm = dsave(13) + stp = dsave(14) + gdold = dsave(15) + dtd = dsave(16) + +c After returning from the driver go to the point where execution +c is to resume. + + if (task(1:5) .eq. 'FG_LN') goto 666 + if (task(1:5) .eq. 'NEW_X') goto 777 + if (task(1:5) .eq. 'FG_ST') goto 111 + if (task(1:4) .eq. 'STOP') then + if (task(7:9) .eq. 'CPU') then +c restore the previous iterate. + call dcopy(n,t,1,x,1) + call dcopy(n,r,1,g,1) + f = fold + endif + goto 999 + endif + endif + +c Compute f0 and g0. + + task = 'FG_START' +c return to the driver to calculate f and g; reenter at 111. + goto 1000 + 111 continue + nfgv = 1 + +c Compute the infinity norm of the (-) projected gradient. + + call projgr(n,l,u,nbd,x,g,sbgnrm) + + if (iprint .ge. 1) then + write (6,1002) iter,f,sbgnrm + write (itfile,1003) iter,nfgv,sbgnrm,f + print*,'Gradient: ',sbgnrm + endif + if (sbgnrm .le. pgtol) then +c terminate the algorithm. + task = 'CONVERGENCE: NORM OF PROJECTED GRADIENT <= PGTOL' + goto 999 + endif + +c ----------------- the beginning of the loop -------------------------- + + 222 continue + if (iprint .ge. 99) write (6,1001) iter + 1 + iword = -1 +c + if (.not. cnstnd .and. col .gt. 0) then +c skip the search for GCP. + call dcopy(n,x,1,z,1) + wrk = updatd + nint = 0 + goto 333 + endif + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c +c Compute the Generalized Cauchy Point (GCP). +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + call timer(cpu1) + print*,'calls cauchy' + call cauchy(n,x,l,u,nbd,g,indx2,iwhere,t,d,z, + + m,wy,ws,sy,wt,theta,col,head, + + wa(1),wa(2*m+1),wa(4*m+1),wa(6*m+1),nint, + + iprint,sbgnrm,info,epsmch) + if (info .ne. 0) then +c singular triangular system detected; refresh the lbfgs memory. + if(iprint .ge. 1) write (6, 1005) + info = 0 + col = 0 + head = 1 + theta = one + iupdat = 0 + updatd = .false. + call timer(cpu2) + cachyt = cachyt + cpu2 - cpu1 + goto 222 + endif + call timer(cpu2) + cachyt = cachyt + cpu2 - cpu1 + nintol = nintol + nint + +c Count the entering and leaving variables for iter > 0; +c find the index set of free and active variables at the GCP. + + call freev(n,nfree,index,nenter,ileave,indx2, + + iwhere,wrk,updatd,cnstnd,iprint,iter) + + nact = n - nfree + + 333 continue + +c If there are no free variables or B=theta*I, then +c skip the subspace minimization. + + if (nfree .eq. 0 .or. col .eq. 0) goto 555 + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c +c Subspace minimization. +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + call timer(cpu1) + +c Form the LEL^T factorization of the indefinite +c matrix K = [-D -Y'ZZ'Y/theta L_a'-R_z' ] +c [L_a -R_z theta*S'AA'S ] +c where E = [-I 0] +c [ 0 I] + + if (wrk) call formk(n,nfree,index,nenter,ileave,indx2,iupdat, + + updatd,wn,snd,m,ws,wy,sy,theta,col,head,info) + if (info .ne. 0) then +c nonpositive definiteness in Cholesky factorization; +c refresh the lbfgs memory and restart the iteration. + if(iprint .ge. 1) write (6, 1006) + info = 0 + col = 0 + head = 1 + theta = one + iupdat = 0 + updatd = .false. + call timer(cpu2) + sbtime = sbtime + cpu2 - cpu1 + goto 222 + endif + +c compute r=-Z'B(xcp-xk)-Z'g (using wa(2m+1)=W'(xcp-x) +c from 'cauchy'). + call cmprlb(n,m,x,g,ws,wy,sy,wt,z,r,wa,index, + + theta,col,head,nfree,cnstnd,info) + if (info .ne. 0) goto 444 +c call the direct method. + call subsm(n,m,nfree,index,l,u,nbd,z,r,ws,wy,theta, + + col,head,iword,wa,wn,iprint,info) + 444 continue + if (info .ne. 0) then +c singular triangular system detected; +c refresh the lbfgs memory and restart the iteration. + if(iprint .ge. 1) write (6, 1005) + info = 0 + col = 0 + head = 1 + theta = one + iupdat = 0 + updatd = .false. + call timer(cpu2) + sbtime = sbtime + cpu2 - cpu1 + goto 222 + endif + + call timer(cpu2) + sbtime = sbtime + cpu2 - cpu1 + 555 continue + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c +c Line search and optimality tests. +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +c Generate the search direction d:=z-x. + + do 40 i = 1, n + d(i) = z(i) - x(i) + 40 continue + call timer(cpu1) + 666 continue + call lnsrlb(n,l,u,nbd,x,f,fold,gd,gdold,g,d,r,t,z,stp,dnorm, + + dtd,xstep,stpmx,iter,ifun,iback,nfgv,info,task, + + boxed,cnstnd,csave,isave(22),dsave(17)) + if (info .ne. 0 .or. iback .ge. 20) then +c restore the previous iterate. + call dcopy(n,t,1,x,1) + call dcopy(n,r,1,g,1) + f = fold + if (col .eq. 0) then +c abnormal termination. + if (info .eq. 0) then + info = -9 +c restore the actual number of f and g evaluations etc. + nfgv = nfgv - 1 + ifun = ifun - 1 + iback = iback - 1 + endif + task = 'ABNORMAL_TERMINATION_IN_LNSRCH' + iter = iter + 1 + goto 999 + else +c refresh the lbfgs memory and restart the iteration. + if(iprint .ge. 1) write (6, 1008) + if (info .eq. 0) nfgv = nfgv - 1 + info = 0 + col = 0 + head = 1 + theta = one + iupdat = 0 + updatd = .false. + task = 'RESTART_FROM_LNSRCH' + call timer(cpu2) + lnscht = lnscht + cpu2 - cpu1 + goto 222 + endif + else if (task(1:5) .eq. 'FG_LN') then +c return to the driver for calculating f and g; reenter at 666. + goto 1000 + else +c calculate and print out the quantities related to the new X. + call timer(cpu2) + lnscht = lnscht + cpu2 - cpu1 + iter = iter + 1 + +c Compute the infinity norm of the projected (-)gradient. + + call projgr(n,l,u,nbd,x,g,sbgnrm) + +c Print iteration information. + + call prn2lb(n,x,f,g,iprint,itfile,iter,nfgv,nact, + + sbgnrm,nint,word,iword,iback,stp,xstep) + goto 1000 + endif + 777 continue + +c Test for termination. + + if (sbgnrm .le. pgtol) then +c terminate the algorithm. + task = 'CONVERGENCE: NORM OF PROJECTED GRADIENT <= PGTOL' + goto 999 + endif + + ddum = max(abs(fold), abs(f), one) + if ((fold - f) .le. tol*ddum) then +c terminate the algorithm. + task = 'CONVERGENCE: REL_REDUCTION_OF_F <= FACTR*EPSMCH' + if (iback .ge. 10) info = -5 +c i.e., to issue a warning if iback>10 in the line search. + goto 999 + endif + +c Compute d=newx-oldx, r=newg-oldg, rr=y'y and dr=y's. + + do 42 i = 1, n + r(i) = g(i) - r(i) + 42 continue + rr = ddot(n,r,1,r,1) + if (stp .eq. one) then + dr = gd - gdold + ddum = -gdold + else + dr = (gd - gdold)*stp + call dscal(n,stp,d,1) + ddum = -gdold*stp + endif + + if (dr .le. epsmch*ddum) then +c skip the L-BFGS update. + nskip = nskip + 1 + updatd = .false. + if (iprint .ge. 1) write (6,1004) dr, ddum + goto 888 + endif + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c +c Update the L-BFGS matrix. +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + updatd = .true. + iupdat = iupdat + 1 + +c Update matrices WS and WY and form the middle matrix in B. + + call matupd(n,m,ws,wy,sy,ss,d,r,itail, + + iupdat,col,head,theta,rr,dr,stp,dtd) + +c Form the upper half of the pds T = theta*SS + L*D^(-1)*L'; +c Store T in the upper triangular of the array wt; +c Cholesky factorize T to J*J' with +c J' stored in the upper triangular of wt. + + call formt(m,wt,sy,ss,col,theta,info) + + if (info .ne. 0) then +c nonpositive definiteness in Cholesky factorization; +c refresh the lbfgs memory and restart the iteration. + if(iprint .ge. 1) write (6, 1007) + info = 0 + col = 0 + head = 1 + theta = one + iupdat = 0 + updatd = .false. + goto 222 + endif + +c Now the inverse of the middle matrix in B is + +c [ D^(1/2) O ] [ -D^(1/2) D^(-1/2)*L' ] +c [ -L*D^(-1/2) J ] [ 0 J' ] + + 888 continue + +c -------------------- the end of the loop ----------------------------- + + goto 222 + 999 continue + call timer(time2) + time = time2 - time1 + call prn3lb(n,x,f,task,iprint,info,itfile, + + iter,nfgv,nintol,nskip,nact,sbgnrm, + + time,nint,word,iback,stp,xstep,k, + + cachyt,sbtime,lnscht) + 1000 continue + +c Save local variables. + + lsave(1) = prjctd + lsave(2) = cnstnd + lsave(3) = boxed + lsave(4) = updatd + + isave(1) = nintol + isave(3) = itfile + isave(4) = iback + isave(5) = nskip + isave(6) = head + isave(7) = col + isave(8) = itail + isave(9) = iter + isave(10) = iupdat + isave(12) = nint + isave(13) = nfgv + isave(14) = info + isave(15) = ifun + isave(16) = iword + isave(17) = nfree + isave(18) = nact + isave(19) = ileave + isave(20) = nenter + + dsave(1) = theta + dsave(2) = fold + dsave(3) = tol + dsave(4) = dnorm + dsave(5) = epsmch + dsave(6) = cpu1 + dsave(7) = cachyt + dsave(8) = sbtime + dsave(9) = lnscht + dsave(10) = time1 + dsave(11) = gd + dsave(12) = stpmx + dsave(13) = sbgnrm + dsave(14) = stp + dsave(15) = gdold + dsave(16) = dtd + + 1001 format (//,'ITERATION ',i5) + 1002 format + + (/,'At iterate',i5,4x,'f= ',1p,d12.5,4x,'|proj g|= ',1p,d12.5) + 1003 format (2(1x,i4),5x,'-',5x,'-',3x,'-',5x,'-',5x,'-',8x,'-',3x, + + 1p,2(1x,d10.3)) + 1004 format (' ys=',1p,e10.3,' -gs=',1p,e10.3,' BFGS update SKIPPED') + 1005 format (/, + +' Singular triangular system detected;',/, + +' refresh the lbfgs memory and restart the iteration.') + 1006 format (/, + +' Nonpositive definiteness in Cholesky factorization in formk;',/, + +' refresh the lbfgs memory and restart the iteration.') + 1007 format (/, + +' Nonpositive definiteness in Cholesky factorization in formt;',/, + +' refresh the lbfgs memory and restart the iteration.') + 1008 format (/, + +' Bad direction in the line search;',/, + +' refresh the lbfgs memory and restart the iteration.') + + return + + end + +c======================= The end of mainlb ============================= + + subroutine active(n, l, u, nbd, x, iwhere, iprint, + + prjctd, cnstnd, boxed) + + logical prjctd, cnstnd, boxed + integer n, iprint, nbd(n), iwhere(n) + real(8)x(n), l(n), u(n) + +c ************ +c +c Subroutine active +c +c This subroutine initializes iwhere and projects the initial x to +c the feasible set if necessary. +c +c iwhere is an integer array of dimension n. +c On entry iwhere is unspecified. +c On exit iwhere(i)=-1 if x(i) has no bounds +c 3 if l(i)=u(i) +c 0 otherwise. +c In cauchy, iwhere is given finer gradations. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer nbdd,i + real(8)zero + parameter (zero=0.0d0) + +c Initialize nbdd, prjctd, cnstnd and boxed. + + nbdd = 0 + prjctd = .false. + cnstnd = .false. + boxed = .true. + +c Project the initial x to the easible set if necessary. + + do 10 i = 1, n + if (nbd(i) .gt. 0) then + if (nbd(i) .le. 2 .and. x(i) .le. l(i)) then + if (x(i) .lt. l(i)) then + prjctd = .true. + x(i) = l(i) + endif + nbdd = nbdd + 1 + else if (nbd(i) .ge. 2 .and. x(i) .ge. u(i)) then + if (x(i) .gt. u(i)) then + prjctd = .true. + x(i) = u(i) + endif + nbdd = nbdd + 1 + endif + endif + 10 continue + +c Initialize iwhere and assign values to cnstnd and boxed. + + do 20 i = 1, n + if (nbd(i) .ne. 2) boxed = .false. + if (nbd(i) .eq. 0) then +c this variable is always free + iwhere(i) = -1 + +c otherwise set x(i)=mid(x(i), u(i), l(i)). + else + cnstnd = .true. + if (nbd(i) .eq. 2 .and. u(i) - l(i) .le. zero) then +c this variable is always fixed + iwhere(i) = 3 + else + iwhere(i) = 0 + endif + endif + 20 continue + + if (iprint .ge. 0) then + if (prjctd) write (6,*) + + 'The initial X is infeasible. Restart with its projection.' + if (.not. cnstnd) + + write (6,*) 'This problem is unconstrained.' + endif + + if (iprint .gt. 0) write (6,1001) nbdd + + 1001 format (/,'At X0 ',i9,' variables are exactly at the bounds') + + return + + end + +c======================= The end of active ============================= + + subroutine bmv(m, sy, wt, col, v, p, info) + + integer m, col, info + real(8)sy(m, m), wt(m, m), v(2*col), p(2*col) + +c ************ +c +c Subroutine bmv +c +c This subroutine computes the product of the 2m x 2m middle matrix +c in the compact L-BFGS formula of B and a 2m vector v; +c it returns the product in p. +c +c m is an integer variable. +c On entry m is the maximum number of variable metric corrections +c used to define the limited memory matrix. +c On exit m is unchanged. +c +c sy is a real(8)array of dimension m x m. +c On entry sy specifies the matrix S'Y. +c On exit sy is unchanged. +c +c wt is a real(8)array of dimension m x m. +c On entry wt specifies the upper triangular matrix J' which is +c the Cholesky factor of (thetaS'S+LD^(-1)L'). +c On exit wt is unchanged. +c +c col is an integer variable. +c On entry col specifies the number of s-vectors (or y-vectors) +c stored in the compact L-BFGS formula. +c On exit col is unchanged. +c +c v is a real(8)array of dimension 2col. +c On entry v specifies vector v. +c On exit v is unchanged. +c +c p is a real(8)array of dimension 2col. +c On entry p is unspecified. +c On exit p is the product Mv. +c +c info is an integer variable. +c On entry info is unspecified. +c On exit info = 0 for normal return, +c = nonzero for abnormal return when the system +c to be solved by dtrsl is singular. +c +c Subprograms called: +c +c Linpack ... dtrsl. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer i,k,i2 + real(8)sum + + if (col .eq. 0) return + +c PART I: solve [ D^(1/2) O ] [ p1 ] = [ v1 ] +c [ -L*D^(-1/2) J ] [ p2 ] [ v2 ]. + +c solve Jp2=v2+LD^(-1)v1. + p(col + 1) = v(col + 1) + do 20 i = 2, col + i2 = col + i + sum = 0.0d0 + do 10 k = 1, i - 1 + sum = sum + sy(i,k)*v(k)/sy(k,k) + 10 continue + p(i2) = v(i2) + sum + 20 continue +c Solve the triangular system + call dtrsl(wt,m,col,p(col+1),11,info) + if (info .ne. 0) return + +c solve D^(1/2)p1=v1. + do 30 i = 1, col + p(i) = v(i)/sqrt(sy(i,i)) + 30 continue + +c PART II: solve [ -D^(1/2) D^(-1/2)*L' ] [ p1 ] = [ p1 ] +c [ 0 J' ] [ p2 ] [ p2 ]. + +c solve J^Tp2=p2. + call dtrsl(wt,m,col,p(col+1),01,info) + if (info .ne. 0) return + +c compute p1=-D^(-1/2)(p1-D^(-1/2)L'p2) +c =-D^(-1/2)p1+D^(-1)L'p2. + do 40 i = 1, col + p(i) = -p(i)/sqrt(sy(i,i)) + 40 continue + do 60 i = 1, col + sum = 0.d0 + do 50 k = i + 1, col + sum = sum + sy(k,i)*p(col+k)/sy(i,i) + 50 continue + p(i) = p(i) + sum + 60 continue + + return + + end + +c======================== The end of bmv =============================== + + subroutine cauchy(n, x, l, u, nbd, g, iorder, iwhere, t, d, xcp, + + m, wy, ws, sy, wt, theta, col, head, p, c, wbp, + + v, nint, iprint, sbgnrm, info, epsmch) + + integer n, m, head, col, nint, iprint, info, + + nbd(n), iorder(n), iwhere(n) + real(8)theta, epsmch, + + x(n), l(n), u(n), g(n), t(n), d(n), xcp(n), + + wy(n, col), ws(n, col), sy(m, m), + + wt(m, m), p(2*m), c(2*m), wbp(2*m), v(2*m) + +c ************ +c +c Subroutine cauchy +c +c For given x, l, u, g (with sbgnrm > 0), and a limited memory +c BFGS matrix B defined in terms of matrices WY, WS, WT, and +c scalars head, col, and theta, this subroutine computes the +c generalized Cauchy point (GCP), defined as the first local +c minimizer of the quadratic +c +c Q(x + s) = g's + 1/2 s'Bs +c +c along the projected gradient direction P(x-tg,l,u). +c The routine returns the GCP in xcp. +c +c n is an integer variable. +c On entry n is the dimension of the problem. +c On exit n is unchanged. +c +c x is a real(8)array of dimension n. +c On entry x is the starting point for the GCP computation. +c On exit x is unchanged. +c +c l is a real(8)array of dimension n. +c On entry l is the lower bound of x. +c On exit l is unchanged. +c +c u is a real(8)array of dimension n. +c On entry u is the upper bound of x. +c On exit u is unchanged. +c +c nbd is an integer array of dimension n. +c On entry nbd represents the type of bounds imposed on the +c variables, and must be specified as follows: +c nbd(i)=0 if x(i) is unbounded, +c 1 if x(i) has only a lower bound, +c 2 if x(i) has both lower and upper bounds, and +c 3 if x(i) has only an upper bound. +c On exit nbd is unchanged. +c +c g is a real(8)array of dimension n. +c On entry g is the gradient of f(x). g must be a nonzero vector. +c On exit g is unchanged. +c +c iorder is an integer working array of dimension n. +c iorder will be used to store the breakpoints in the piecewise +c linear path and free variables encountered. On exit, +c iorder(1),...,iorder(nleft) are indices of breakpoints +c which have not been encountered; +c iorder(nleft+1),...,iorder(nbreak) are indices of +c encountered breakpoints; and +c iorder(nfree),...,iorder(n) are indices of variables which +c have no bound constraits along the search direction. +c +c iwhere is an integer array of dimension n. +c On entry iwhere indicates only the permanently fixed (iwhere=3) +c or free (iwhere= -1) components of x. +c On exit iwhere records the status of the current x variables. +c iwhere(i)=-3 if x(i) is free and has bounds, but is not moved +c 0 if x(i) is free and has bounds, and is moved +c 1 if x(i) is fixed at l(i), and l(i) .ne. u(i) +c 2 if x(i) is fixed at u(i), and u(i) .ne. l(i) +c 3 if x(i) is always fixed, i.e., u(i)=x(i)=l(i) +c -1 if x(i) is always free, i.e., it has no bounds. +c +c t is a real(8)working array of dimension n. +c t will be used to store the break points. +c +c d is a real(8)array of dimension n used to store +c the Cauchy direction P(x-tg)-x. +c +c xcp is a real(8)array of dimension n used to return the +c GCP on exit. +c +c m is an integer variable. +c On entry m is the maximum number of variable metric corrections +c used to define the limited memory matrix. +c On exit m is unchanged. +c +c ws, wy, sy, and wt are real(8)arrays. +c On entry they store information that defines the +c limited memory BFGS matrix: +c ws(n,m) stores S, a set of s-vectors; +c wy(n,m) stores Y, a set of y-vectors; +c sy(m,m) stores S'Y; +c wt(m,m) stores the +c Cholesky factorization of (theta*S'S+LD^(-1)L'). +c On exit these arrays are unchanged. +c +c theta is a real(8)variable. +c On entry theta is the scaling factor specifying B_0 = theta I. +c On exit theta is unchanged. +c +c col is an integer variable. +c On entry col is the actual number of variable metric +c corrections stored so far. +c On exit col is unchanged. +c +c head is an integer variable. +c On entry head is the location of the first s-vector (or y-vector) +c in S (or Y). +c On exit col is unchanged. +c +c p is a real(8)working array of dimension 2m. +c p will be used to store the vector p = W^(T)d. +c +c c is a real(8)working array of dimension 2m. +c c will be used to store the vector c = W^(T)(xcp-x). +c +c wbp is a real(8)working array of dimension 2m. +c wbp will be used to store the row of W corresponding +c to a breakpoint. +c +c v is a real(8)working array of dimension 2m. +c +c nint is an integer variable. +c On exit nint records the number of quadratic segments explored +c in searching for the GCP. +c +c sg and yg are real(8)arrays of dimension m. +c On entry sg and yg store S'g and Y'g correspondingly. +c On exit they are unchanged. +c +c iprint is an INTEGER variable that must be set by the user. +c It controls the frequency and type of output generated: +c iprint<0 no output is generated; +c iprint=0 print only one line at the last iteration; +c 0100 print details of every iteration including x and g; +c When iprint > 0, the file iterate.dat will be created to +c summarize the iteration. +c +c sbgnrm is a real(8)variable. +c On entry sbgnrm is the norm of the projected gradient at x. +c On exit sbgnrm is unchanged. +c +c info is an integer variable. +c On entry info is 0. +c On exit info = 0 for normal return, +c = nonzero for abnormal return when the the system +c used in routine bmv is singular. +c +c Subprograms called: +c +c L-BFGS-B Library ... hpsolb, bmv. +c +c Linpack ... dscal dcopy, daxpy. +c +c +c References: +c +c [1] R. H. Byrd, P. Lu, J. Nocedal and C. Zhu, ``A limited +c memory algorithm for bound constrained optimization'', +c SIAM J. Scientific Computing 16 (1995), no. 5, pp. 1190--1208. +c +c [2] C. Zhu, R.H. Byrd, P. Lu, J. Nocedal, ``L-BFGS-B: FORTRAN +c Subroutines for Large Scale Bound Constrained Optimization'' +c Tech. Report, NAM-11, EECS Department, Northwestern University, +c 1994. +c +c (Postscript files of these papers are available via anonymous +c ftp to eecs.nwu.edu in the directory pub/lbfgs/lbfgs_bcm.) +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + logical xlower,xupper,bnded + integer i,j,col2,nfree,nbreak,pointr, + + ibp,nleft,ibkmin,iter + real(8)f1,f2,dt,dtm,tsum,dibp,zibp,dibp2,bkmin, + + tu,tl,wmc,wmp,wmw,ddot,tj,tj0,neggi,sbgnrm, + + f2_org + real(8)one,zero + parameter (one=1.0d0,zero=0.0d0) + +c Check the status of the variables, reset iwhere(i) if necessary; +c compute the Cauchy direction d and the breakpoints t; initialize +c the derivative f1 and the vector p = W'd (for theta = 1). + + if (sbgnrm .le. zero) then + if (iprint .ge. 0) write (6,*) 'Subgnorm = 0. GCP = X.' + call dcopy(n,x,1,xcp,1) + return + endif + bnded = .true. + nfree = n + 1 + nbreak = 0 + ibkmin = 0 + bkmin = zero + col2 = 2*col + f1 = zero + if (iprint .ge. 99) write (6,3010) + +c We set p to zero and build it up as we determine d. + + do 20 i = 1, col2 + p(i) = zero + 20 continue + +c In the following loop we determine for each variable its bound +c status and its breakpoint, and update p accordingly. +c Smallest breakpoint is identified. + + do 50 i = 1, n + neggi = -g(i) + if (iwhere(i) .ne. 3 .and. iwhere(i) .ne. -1) then +c if x(i) is not a constant and has bounds, +c compute the difference between x(i) and its bounds. + if (nbd(i) .le. 2) tl = x(i) - l(i) + if (nbd(i) .ge. 2) tu = u(i) - x(i) + +c If a variable is close enough to a bound +c we treat it as at bound. + xlower = nbd(i) .le. 2 .and. tl .le. zero + xupper = nbd(i) .ge. 2 .and. tu .le. zero + +c reset iwhere(i). + iwhere(i) = 0 + if (xlower) then + if (neggi .le. zero) iwhere(i) = 1 + else if (xupper) then + if (neggi .ge. zero) iwhere(i) = 2 + else + if (abs(neggi) .le. zero) iwhere(i) = -3 + endif + endif + pointr = head + if (iwhere(i) .ne. 0 .and. iwhere(i) .ne. -1) then + d(i) = zero + else + d(i) = neggi + f1 = f1 - neggi*neggi +c calculate p := p - W'e_i* (g_i). + do 40 j = 1, col + p(j) = p(j) + wy(i,pointr)* neggi + p(col + j) = p(col + j) + ws(i,pointr)*neggi + pointr = mod(pointr,m) + 1 + 40 continue + if (nbd(i) .le. 2 .and. nbd(i) .ne. 0 + + .and. neggi .lt. zero) then +c x(i) + d(i) is bounded; compute t(i). + nbreak = nbreak + 1 + iorder(nbreak) = i + t(nbreak) = tl/(-neggi) + if (nbreak .eq. 1 .or. t(nbreak) .lt. bkmin) then + bkmin = t(nbreak) + ibkmin = nbreak + endif + else if (nbd(i) .ge. 2 .and. neggi .gt. zero) then +c x(i) + d(i) is bounded; compute t(i). + nbreak = nbreak + 1 + iorder(nbreak) = i + t(nbreak) = tu/neggi + if (nbreak .eq. 1 .or. t(nbreak) .lt. bkmin) then + bkmin = t(nbreak) + ibkmin = nbreak + endif + else +c x(i) + d(i) is not bounded. + nfree = nfree - 1 + iorder(nfree) = i + if (abs(neggi) .gt. zero) bnded = .false. + endif + endif + 50 continue + +c The indices of the nonzero components of d are now stored +c in iorder(1),...,iorder(nbreak) and iorder(nfree),...,iorder(n). +c The smallest of the nbreak breakpoints is in t(ibkmin)=bkmin. + + if (theta .ne. one) then +c complete the initialization of p for theta not= one. + call dscal(col,theta,p(col+1),1) + endif + +c Initialize GCP xcp = x. + + call dcopy(n,x,1,xcp,1) + + if (nbreak .eq. 0 .and. nfree .eq. n + 1) then +c is a zero vector, return with the initial xcp as GCP. + if (iprint .gt. 100) write (6,1010) (xcp(i), i = 1, n) + return + endif + +c Initialize c = W'(xcp - x) = 0. + + do 60 j = 1, col2 + c(j) = zero + 60 continue + +c Initialize derivative f2. + + f2 = -theta*f1 + f2_org = f2 + if (col .gt. 0) then + call bmv(m,sy,wt,col,p,v,info) + if (info .ne. 0) return + f2 = f2 - ddot(col2,v,1,p,1) + endif + dtm = -f1/f2 + tsum = zero + nint = 1 + if (iprint .ge. 99) + + write (6,*) 'There are ',nbreak,' breakpoints ' + +c If there are no breakpoints, locate the GCP and return. + + if (nbreak .eq. 0) goto 888 + + nleft = nbreak + iter = 1 + + + tj = zero + +c------------------- the beginning of the loop ------------------------- + + 777 continue + +c Find the next smallest breakpoint; +c compute dt = t(nleft) - t(nleft + 1). + + tj0 = tj + if (iter .eq. 1) then +c Since we already have the smallest breakpoint we need not do +c heapsort yet. Often only one breakpoint is used and the +c cost of heapsort is avoided. + tj = bkmin + ibp = iorder(ibkmin) + else + if (iter .eq. 2) then +c Replace the already used smallest breakpoint with the +c breakpoint numbered nbreak > nlast, before heapsort call. + if (ibkmin .ne. nbreak) then + t(ibkmin) = t(nbreak) + iorder(ibkmin) = iorder(nbreak) + endif +c Update heap structure of breakpoints +c (if iter=2, initialize heap). + endif + call hpsolb(nleft,t,iorder,iter-2) + tj = t(nleft) + ibp = iorder(nleft) + endif + + dt = tj - tj0 + + if (dt .ne. zero .and. iprint .ge. 100) then + write (6,4011) nint,f1,f2 + write (6,5010) dt + write (6,6010) dtm + endif + +c If a minimizer is within this interval, locate the GCP and return. + + if (dtm .lt. dt) goto 888 + +c Otherwise fix one variable and +c reset the corresponding component of d to zero. + + tsum = tsum + dt + nleft = nleft - 1 + iter = iter + 1 + dibp = d(ibp) + d(ibp) = zero + if (dibp .gt. zero) then + zibp = u(ibp) - x(ibp) + xcp(ibp) = u(ibp) + iwhere(ibp) = 2 + else + zibp = l(ibp) - x(ibp) + xcp(ibp) = l(ibp) + iwhere(ibp) = 1 + endif + if (iprint .ge. 100) write (6,*) 'Variable ',ibp,' is fixed.' + if (nleft .eq. 0 .and. nbreak .eq. n) then +c all n variables are fixed, +c return with xcp as GCP. + dtm = dt + goto 999 + endif + +c Update the derivative information. + + nint = nint + 1 + dibp2 = dibp**2 + +c Update f1 and f2. + +c temporarily set f1 and f2 for col=0. + f1 = f1 + dt*f2 + dibp2 - theta*dibp*zibp + f2 = f2 - theta*dibp2 + + if (col .gt. 0) then +c update c = c + dt*p. + call daxpy(col2,dt,p,1,c,1) + +c choose wbp, +c the row of W corresponding to the breakpoint encountered. + pointr = head + do 70 j = 1,col + wbp(j) = wy(ibp,pointr) + wbp(col + j) = theta*ws(ibp,pointr) + pointr = mod(pointr,m) + 1 + 70 continue + +c compute (wbp)Mc, (wbp)Mp, and (wbp)M(wbp)'. + call bmv(m,sy,wt,col,wbp,v,info) + if (info .ne. 0) return + wmc = ddot(col2,c,1,v,1) + wmp = ddot(col2,p,1,v,1) + wmw = ddot(col2,wbp,1,v,1) + +c update p = p - dibp*wbp. + call daxpy(col2,-dibp,wbp,1,p,1) + +c complete updating f1 and f2 while col > 0. + f1 = f1 + dibp*wmc + f2 = f2 + 2.0d0*dibp*wmp - dibp2*wmw + endif + + f2 = max(epsmch*f2_org,f2) + if (nleft .gt. 0) then + dtm = -f1/f2 + goto 777 +c to repeat the loop for unsearched intervals. + else if(bnded) then + f1 = zero + f2 = zero + dtm = zero + else + dtm = -f1/f2 + endif + +c------------------- the end of the loop ------------------------------- + + 888 continue + if (iprint .ge. 99) then + write (6,*) + write (6,*) 'GCP found in this segment' + write (6,4010) nint,f1,f2 + write (6,6010) dtm + endif + if (dtm .le. zero) dtm = zero + tsum = tsum + dtm + +c Move free variables (i.e., the ones w/o breakpoints) and +c the variables whose breakpoints haven't been reached. + + call daxpy(n,tsum,d,1,xcp,1) + + 999 continue + +c Update c = c + dtm*p = W'(x^c - x) +c which will be used in computing r = Z'(B(x^c - x) + g). + + if (col .gt. 0) call daxpy(col2,dtm,p,1,c,1) + if (iprint .gt. 100) write (6,1010) (xcp(i),i = 1,n) + if (iprint .ge. 99) write (6,2010) + + 1010 format ('Cauchy X = ',/,(4x,1p,6(1x,d11.4))) + 2010 format (/,'---------------- exit CAUCHY----------------------',/) + 3010 format (/,'---------------- CAUCHY entered-------------------') + 4010 format ('Piece ',i3,' --f1, f2 at start point ',1p,2(1x,d11.4)) + 4011 format (/,'Piece ',i3,' --f1, f2 at start point ', + + 1p,2(1x,d11.4)) + 5010 format ('Distance to the next break point = ',1p,d11.4) + 6010 format ('Distance to the stationary point = ',1p,d11.4) + + return + + end + +c====================== The end of cauchy ============================== + + subroutine cmprlb(n, m, x, g, ws, wy, sy, wt, z, r, wa, index, + + theta, col, head, nfree, cnstnd, info) + + logical cnstnd + integer n, m, col, head, nfree, info, index(n) + real(8)theta, + + x(n), g(n), z(n), r(n), wa(4*m), + + ws(n, m), wy(n, m), sy(m, m), wt(m, m) + +c ************ +c +c Subroutine cmprlb +c +c This subroutine computes r=-Z'B(xcp-xk)-Z'g by using +c wa(2m+1)=W'(xcp-x) from subroutine cauchy. +c +c Subprograms called: +c +c L-BFGS-B Library ... bmv. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer i,j,k,pointr + real(8)a1,a2 + + if (.not. cnstnd .and. col .gt. 0) then + do 26 i = 1, n + r(i) = -g(i) + 26 continue + else + do 30 i = 1, nfree + k = index(i) + r(i) = -theta*(z(k) - x(k)) - g(k) + 30 continue + call bmv(m,sy,wt,col,wa(2*m+1),wa(1),info) + if (info .ne. 0) then + info = -8 + return + endif + pointr = head + do 34 j = 1, col + a1 = wa(j) + a2 = theta*wa(col + j) + do 32 i = 1, nfree + k = index(i) + r(i) = r(i) + wy(k,pointr)*a1 + ws(k,pointr)*a2 + 32 continue + pointr = mod(pointr,m) + 1 + 34 continue + endif + + return + + end + +c======================= The end of cmprlb ============================= + + subroutine errclb(n, m, factr, l, u, nbd, task, info, k) + + character(LEN=60) task + integer n, m, info, k, nbd(n) + real(8)factr, l(n), u(n) + +c ************ +c +c Subroutine errclb +c +c This subroutine checks the validity of the input data. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer i + real(8)zero + parameter (zero=0.0d0) + +c Check the input arguments for errors. + + if (n .le. 0) task = 'ERROR: N .LE. 0' + if (m .le. 0) task = 'ERROR: M .LE. 0' + if (factr .lt. zero) task = 'ERROR: FACTR .LT. 0' + +c Check the validity of the arrays nbd(i), u(i), and l(i). + + do 10 i = 1, n + if (nbd(i) .lt. 0 .or. nbd(i) .gt. 3) then +c return + task = 'ERROR: INVALID NBD' + info = -6 + k = i + endif + if (nbd(i) .eq. 2) then + if (l(i) .gt. u(i)) then +c return + task = 'ERROR: NO FEASIBLE SOLUTION' + info = -7 + k = i + endif + endif + 10 continue + + return + + end + +c======================= The end of errclb ============================= + + subroutine formk(n, nsub, ind, nenter, ileave, indx2, iupdat, + + updatd, wn, wn1, m, ws, wy, sy, theta, col, + + head, info) + + integer n, nsub, m, col, head, nenter, ileave, iupdat, + + info, ind(n), indx2(n) + real(8)theta, wn(2*m, 2*m), wn1(2*m, 2*m), + + ws(n, m), wy(n, m), sy(m, m) + logical updatd + +c ************ +c +c Subroutine formk +c +c This subroutine forms the LEL^T factorization of the indefinite +c +c matrix K = [-D -Y'ZZ'Y/theta L_a'-R_z' ] +c [L_a -R_z theta*S'AA'S ] +c where E = [-I 0] +c [ 0 I] +c The matrix K can be shown to be equal to the matrix M^[-1]N +c occurring in section 5.1 of [1], as well as to the matrix +c Mbar^[-1] Nbar in section 5.3. +c +c n is an integer variable. +c On entry n is the dimension of the problem. +c On exit n is unchanged. +c +c nsub is an integer variable +c On entry nsub is the number of subspace variables in free set. +c On exit nsub is not changed. +c +c ind is an integer array of dimension nsub. +c On entry ind specifies the indices of subspace variables. +c On exit ind is unchanged. +c +c nenter is an integer variable. +c On entry nenter is the number of variables entering the +c free set. +c On exit nenter is unchanged. +c +c ileave is an integer variable. +c On entry indx2(ileave),...,indx2(n) are the variables leaving +c the free set. +c On exit ileave is unchanged. +c +c indx2 is an integer array of dimension n. +c On entry indx2(1),...,indx2(nenter) are the variables entering +c the free set, while indx2(ileave),...,indx2(n) are the +c variables leaving the free set. +c On exit indx2 is unchanged. +c +c iupdat is an integer variable. +c On entry iupdat is the total number of BFGS updates made so far. +c On exit iupdat is unchanged. +c +c updatd is a logical variable. +c On entry 'updatd' is true if the L-BFGS matrix is updatd. +c On exit 'updatd' is unchanged. +c +c wn is a real(8)array of dimension 2m x 2m. +c On entry wn is unspecified. +c On exit the upper triangle of wn stores the LEL^T factorization +c of the 2*col x 2*col indefinite matrix +c [-D -Y'ZZ'Y/theta L_a'-R_z' ] +c [L_a -R_z theta*S'AA'S ] +c +c wn1 is a real(8)array of dimension 2m x 2m. +c On entry wn1 stores the lower triangular part of +c [Y' ZZ'Y L_a'+R_z'] +c [L_a+R_z S'AA'S ] +c in the previous iteration. +c On exit wn1 stores the corresponding updated matrices. +c The purpose of wn1 is just to store these inner products +c so they can be easily updated and inserted into wn. +c +c m is an integer variable. +c On entry m is the maximum number of variable metric corrections +c used to define the limited memory matrix. +c On exit m is unchanged. +c +c ws, wy, sy, and wtyy are real(8)arrays; +c theta is a real(8)variable; +c col is an integer variable; +c head is an integer variable. +c On entry they store the information defining the +c limited memory BFGS matrix: +c ws(n,m) stores S, a set of s-vectors; +c wy(n,m) stores Y, a set of y-vectors; +c sy(m,m) stores S'Y; +c wtyy(m,m) stores the Cholesky factorization +c of (theta*S'S+LD^(-1)L') +c theta is the scaling factor specifying B_0 = theta I; +c col is the number of variable metric corrections stored; +c head is the location of the 1st s- (or y-) vector in S (or Y). +c On exit they are unchanged. +c +c info is an integer variable. +c On entry info is unspecified. +c On exit info = 0 for normal return; +c = -1 when the 1st Cholesky factorization failed; +c = -2 when the 2st Cholesky factorization failed. +c +c Subprograms called: +c +c Linpack ... dcopy, dpofa, dtrsl. +c +c +c References: +c [1] R. H. Byrd, P. Lu, J. Nocedal and C. Zhu, ``A limited +c memory algorithm for bound constrained optimization'', +c SIAM J. Scientific Computing 16 (1995), no. 5, pp. 1190--1208. +c +c [2] C. Zhu, R.H. Byrd, P. Lu, J. Nocedal, ``L-BFGS-B: a +c limited memory FORTRAN code for solving bound constrained +c optimization problems'', Tech. Report, NAM-11, EECS Department, +c Northwestern University, 1994. +c +c (Postscript files of these papers are available via anonymous +c ftp to eecs.nwu.edu in the directory pub/lbfgs/lbfgs_bcm.) +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer m2,ipntr,jpntr,iy,is,jy,js,is1,js1,k1,i,k, + + col2,pbegin,pend,dbegin,dend,upcl + real(8)ddot,temp1,temp2,temp3,temp4 + real(8)zero + parameter (zero=0.0d0) + +c Form the lower triangular part of +c WN1 = [Y' ZZ'Y L_a'+R_z'] +c [L_a+R_z S'AA'S ] +c where L_a is the strictly lower triangular part of S'AA'Y +c R_z is the upper triangular part of S'ZZ'Y. + + if (updatd) then + if (iupdat .gt. m) then +c shift old part of WN1. + do 10 jy = 1, m - 1 + js = m + jy + call dcopy(m-jy,wn1(jy+1,jy+1),1,wn1(jy,jy),1) + call dcopy(m-jy,wn1(js+1,js+1),1,wn1(js,js),1) + call dcopy(m-1,wn1(m+2,jy+1),1,wn1(m+1,jy),1) + 10 continue + endif + +c put new rows in blocks (1,1), (2,1) and (2,2). + pbegin = 1 + pend = nsub + dbegin = nsub + 1 +!sd dbegin = 1 + dend = n + iy = col + is = m + col + ipntr = head + col - 1 + if (ipntr .gt. m) ipntr = ipntr - m + jpntr = head + do 20 jy = 1, col + js = m + jy + temp1 = zero + temp2 = zero + temp3 = zero +c compute element jy of row 'col' of Y'ZZ'Y + do 15 k = pbegin, pend + k1 = ind(k) + temp1 = temp1 + wy(k1,ipntr)*wy(k1,jpntr) + 15 continue +c compute elements jy of row 'col' of L_a and S'AA'S + do 16 k = dbegin, dend + k1 = ind(k) + temp2 = temp2 + ws(k1,ipntr)*ws(k1,jpntr) + temp3 = temp3 + ws(k1,ipntr)*wy(k1,jpntr) + 16 continue + wn1(iy,jy) = temp1 + wn1(is,js) = temp2 + wn1(is,jy) = temp3 + jpntr = mod(jpntr,m) + 1 + 20 continue + +c put new column in block (2,1). + jy = col + jpntr = head + col - 1 + if (jpntr .gt. m) jpntr = jpntr - m + ipntr = head + do 30 i = 1, col + is = m + i + temp3 = zero +c compute element i of column 'col' of R_z + do 25 k = pbegin, pend + k1 = ind(k) + temp3 = temp3 + ws(k1,ipntr)*wy(k1,jpntr) + 25 continue + ipntr = mod(ipntr,m) + 1 + wn1(is,jy) = temp3 + 30 continue + upcl = col - 1 + else + upcl = col + endif + +c modify.e old parts in blocks (1,1) and (2,2) due to changes +c in the set of free variables. + ipntr = head + do 45 iy = 1, upcl + is = m + iy + jpntr = head + do 40 jy = 1, iy + js = m + jy + temp1 = zero + temp2 = zero + temp3 = zero + temp4 = zero + do 35 k = 1, nenter + k1 = indx2(k) + temp1 = temp1 + wy(k1,ipntr)*wy(k1,jpntr) + temp2 = temp2 + ws(k1,ipntr)*ws(k1,jpntr) + 35 continue + do 36 k = ileave, n + k1 = indx2(k) + temp3 = temp3 + wy(k1,ipntr)*wy(k1,jpntr) + temp4 = temp4 + ws(k1,ipntr)*ws(k1,jpntr) + 36 continue + wn1(iy,jy) = wn1(iy,jy) + temp1 - temp3 + wn1(is,js) = wn1(is,js) - temp2 + temp4 + jpntr = mod(jpntr,m) + 1 + 40 continue + ipntr = mod(ipntr,m) + 1 + 45 continue + +c modify.e old parts in block (2,1). + ipntr = head + do 60 is = m + 1, m + upcl + jpntr = head + do 55 jy = 1, upcl + temp1 = zero + temp3 = zero + do 50 k = 1, nenter + k1 = indx2(k) + temp1 = temp1 + ws(k1,ipntr)*wy(k1,jpntr) + 50 continue + do 51 k = ileave, n + k1 = indx2(k) + temp3 = temp3 + ws(k1,ipntr)*wy(k1,jpntr) + 51 continue + if (is .le. jy + m) then + wn1(is,jy) = wn1(is,jy) + temp1 - temp3 + else + wn1(is,jy) = wn1(is,jy) - temp1 + temp3 + endif + jpntr = mod(jpntr,m) + 1 + 55 continue + ipntr = mod(ipntr,m) + 1 + 60 continue + +c Form the upper triangle of WN = [D+Y' ZZ'Y/theta -L_a'+R_z' ] +c [-L_a +R_z S'AA'S*theta] + + m2 = 2*m + do 70 iy = 1, col + is = col + iy + is1 = m + iy + do 65 jy = 1, iy + js = col + jy + js1 = m + jy + wn(jy,iy) = wn1(iy,jy)/theta + wn(js,is) = wn1(is1,js1)*theta + 65 continue + do 66 jy = 1, iy - 1 + wn(jy,is) = -wn1(is1,jy) + 66 continue + do 67 jy = iy, col + wn(jy,is) = wn1(is1,jy) + 67 continue + wn(iy,iy) = wn(iy,iy) + sy(iy,iy) + 70 continue + +c Form the upper triangle of WN= [ LL' L^-1(-L_a'+R_z')] +c [(-L_a +R_z)L'^-1 S'AA'S*theta ] + +c first Cholesky factor (1,1) block of wn to get LL' +c with L' stored in the upper triangle of wn. + call dpofa(wn,m2,col,info) + if (info .ne. 0) then + info = -1 + return + endif +c then form L^-1(-L_a'+R_z') in the (1,2) block. + col2 = 2*col + do 71 js = col+1 ,col2 + call dtrsl(wn,m2,col,wn(1,js),11,info) + 71 continue + +c Form S'AA'S*theta + (L^-1(-L_a'+R_z'))'L^-1(-L_a'+R_z') in the +c upper triangle of (2,2) block of wn. + + + do 72 is = col+1, col2 + do 74 js = is, col2 + wn(is,js) = wn(is,js) + ddot(col,wn(1,is),1,wn(1,js),1) + 74 continue + 72 continue + +c Cholesky factorization of (2,2) block of wn. + + call dpofa(wn(col+1,col+1),m2,col,info) + if (info .ne. 0) then + info = -2 + return + endif + + return + + end + +c======================= The end of formk ============================== + + subroutine formt(m, wt, sy, ss, col, theta, info) + + integer m, col, info + real(8)theta, wt(m, m), sy(m, m), ss(m, m) + +c ************ +c +c Subroutine formt +c +c This subroutine forms the upper half of the pos. def. and symm. +c T = theta*SS + L*D^(-1)*L', stores T in the upper triangle +c of the array wt, and performs the Cholesky factorization of T +c to produce J*J', with J' stored in the upper triangle of wt. +c +c Subprograms called: +c +c Linpack ... dpofa. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer i,j,k,k1 + real(8)ddum + real(8)zero + parameter (zero=0.0d0) + + +c Form the upper half of T = theta*SS + L*D^(-1)*L', +c store T in the upper triangle of the array wt. + + do 52 j = 1, col + wt(1,j) = theta*ss(1,j) + 52 continue + do 55 i = 2, col + do 54 j = i, col + k1 = min(i,j) - 1 + ddum = zero + do 53 k = 1, k1 + ddum = ddum + sy(i,k)*sy(j,k)/sy(k,k) + 53 continue + wt(i,j) = ddum + theta*ss(i,j) + 54 continue + 55 continue + +c Cholesky factorize T to J*J' with +c J' stored in the upper triangle of wt. + + call dpofa(wt,m,col,info) + if (info .ne. 0) then + info = -3 + endif + + return + + end + +c======================= The end of formt ============================== + + subroutine freev(n, nfree, index, nenter, ileave, indx2, + + iwhere, wrk, updatd, cnstnd, iprint, iter) + + integer n, nfree, nenter, ileave, iprint, iter, + + index(n), indx2(n), iwhere(n) + logical wrk, updatd, cnstnd + +c ************ +c +c Subroutine freev +c +c This subroutine counts the entering and leaving variables when +c iter > 0, and finds the index set of free and active variables +c at the GCP. +c +c cnstnd is a logical variable indicating whether bounds are present +c +c index is an integer array of dimension n +c for i=1,...,nfree, index(i) are the indices of free variables +c for i=nfree+1,...,n, index(i) are the indices of bound variables +c On entry after the first iteration, index gives +c the free variables at the previous iteration. +c On exit it gives the free variables based on the determination +c in cauchy using the array iwhere. +c +c indx2 is an integer array of dimension n +c On entry indx2 is unspecified. +c On exit with iter>0, indx2 indicates which variables +c have changed status since the previous iteration. +c For i= 1,...,nenter, indx2(i) have changed from bound to free. +c For i= ileave+1,...,n, indx2(i) have changed from free to bound. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer iact,i,k + + nenter = 0 + ileave = n + 1 + if (iter .gt. 0 .and. cnstnd) then +c count the entering and leaving variables. + do 20 i = 1, nfree + k = index(i) + if (iwhere(k) .gt. 0) then + ileave = ileave - 1 + indx2(ileave) = k + if (iprint .ge. 100) write (6,*) + + 'Variable ',k,' leaves the set of free variables' + endif + 20 continue + do 22 i = 1 + nfree, n + k = index(i) + if (iwhere(k) .le. 0) then + nenter = nenter + 1 + indx2(nenter) = k + if (iprint .ge. 100) write (6,*) + + 'Variable ',k,' enters the set of free variables' + endif + 22 continue + if (iprint .ge. 99) write (6,*) + + n+1-ileave,' variables leave; ',nenter,' variables enter' + endif + wrk = (ileave .lt. n+1) .or. (nenter .gt. 0) .or. updatd + +c Find the index set of free and active variables at the GCP. + + nfree = 0 + iact = n + 1 + do 24 i = 1, n + if (iwhere(i) .le. 0) then + nfree = nfree + 1 + index(nfree) = i + else + iact = iact - 1 + index(iact) = i + endif + 24 continue + if (iprint .ge. 99) write (6,*) + + nfree,' variables are free at GCP ',iter + 1 + + return + + end + +c======================= The end of freev ============================== + + subroutine hpsolb(n, t, iorder, iheap) + integer iheap, n, iorder(n) + real(8)t(n) + +c ************ +c +c Subroutine hpsolb +c +c This subroutine sorts out the least element of t, and puts the +c remaining elements of t in a heap. +c +c n is an integer variable. +c On entry n is the dimension of the arrays t and iorder. +c On exit n is unchanged. +c +c t is a real(8)array of dimension n. +c On entry t stores the elements to be sorted, +c On exit t(n) stores the least elements of t, and t(1) to t(n-1) +c stores the remaining elements in the form of a heap. +c +c iorder is an integer array of dimension n. +c On entry iorder(i) is the index of t(i). +c On exit iorder(i) is still the index of t(i), but iorder may be +c permuted in accordance with t. +c +c iheap is an integer variable specifying the task. +c On entry iheap should be set as follows: +c iheap .eq. 0 if t(1) to t(n) is not in the form of a heap, +c iheap .ne. 0 if otherwise. +c On exit iheap is unchanged. +c +c +c References: +c Algorithm 232 of CACM (J. W. J. Williams): HEAPSORT. +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c ************ + + integer i,j,k,indxin,indxou + real(8)ddum,out + + if (iheap .eq. 0) then + +c Rearrange the elements t(1) to t(n) to form a heap. + + do 20 k = 2, n + ddum = t(k) + indxin = iorder(k) + +c Add ddum to the heap. + i = k + 10 continue + if (i.gt.1) then + j = i/2 + if (ddum .lt. t(j)) then + t(i) = t(j) + iorder(i) = iorder(j) + i = j + goto 10 + endif + endif + t(i) = ddum + iorder(i) = indxin + 20 continue + endif + +c Assign to 'out' the value of t(1), the least member of the heap, +c and rearrange the remaining members to form a heap as +c elements 1 to n-1 of t. + + if (n .gt. 1) then + i = 1 + out = t(1) + indxou = iorder(1) + ddum = t(n) + indxin = iorder(n) + +c Restore the heap + 30 continue + j = i+i + if (j .le. n-1) then + if (t(j+1) .lt. t(j)) j = j+1 + if (t(j) .lt. ddum ) then + t(i) = t(j) + iorder(i) = iorder(j) + i = j + goto 30 + endif + endif + t(i) = ddum + iorder(i) = indxin + +c Put the least member in t(n). + + t(n) = out + iorder(n) = indxou + endif + + return + + end + +c====================== The end of hpsolb ============================== + + subroutine lnsrlb(n, l, u, nbd, x, f, fold, gd, gdold, g, d, r, t, + + z, stp, dnorm, dtd, xstep, stpmx, iter, ifun, + + iback, nfgv, info, task, boxed, cnstnd, csave, + + isave, dsave) + + character(LEN=60) task, csave + logical boxed, cnstnd + integer n, iter, ifun, iback, nfgv, info, + + nbd(n), isave(2) + real(8)f, fold, gd, gdold, stp, dnorm, dtd, xstep, + + stpmx, x(n), l(n), u(n), g(n), d(n), r(n), t(n), + + z(n), dsave(13) +c ********** +c +c Subroutine lnsrlb +c +c This subroutine calls subroutine dcsrch from the Minpack2 library +c to perform the line search. Subroutine dscrch is safeguarded so +c that all trial points lie within the feasible region. +c +c Subprograms called: +c +c Minpack2 Library ... dcsrch. +c +c Linpack ... dtrsl, ddot. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ********** + + integer i + real(8) ddot,a1,a2 + real(8) one,zero,big + parameter (one=1.0d0,zero=0.0d0,big=1.0d+10) + real(8) ftol,gtol,xtol + parameter (ftol=1.0d-3,gtol=0.9d0,xtol=0.1d0) + + if (task(1:5) .eq. 'FG_LN') goto 556 + + dtd = ddot(n,d,1,d,1) + dnorm = sqrt(dtd) + +c Determine the maximum step length. + + stpmx = big + if (cnstnd) then + if (iter .eq. 0) then + stpmx = one + else + do 43 i = 1, n + a1 = d(i) + if (nbd(i) .ne. 0) then + if (a1 .lt. zero .and. nbd(i) .le. 2) then + a2 = l(i) - x(i) + if (a2 .ge. zero) then + stpmx = zero + else if (a1*stpmx .lt. a2) then + stpmx = a2/a1 + endif + else if (a1 .gt. zero .and. nbd(i) .ge. 2) then + a2 = u(i) - x(i) + if (a2 .le. zero) then + stpmx = zero + else if (a1*stpmx .gt. a2) then + stpmx = a2/a1 + endif + endif + endif + 43 continue + endif + endif + + if (iter .eq. 0 .and. .not. boxed) then + stp = min(one/dnorm, stpmx) + else + stp = one + endif + + call dcopy(n,x,1,t,1) + call dcopy(n,g,1,r,1) + fold = f + ifun = 0 + iback = 0 + csave = 'START' + 556 continue + gd = ddot(n,g,1,d,1) + if (ifun .eq. 0) then + gdold=gd + if (gd .ge. zero) then +c the directional derivative >=0. +c Line search is impossible. + info = -4 + return + endif + endif + + call dcsrch(f,gd,stp,ftol,gtol,xtol,zero,stpmx,csave,isave,dsave) + + xstep = stp*dnorm + if (csave(1:4) .ne. 'CONV' .and. csave(1:4) .ne. 'WARN') then + task = 'FG_LNSRCH' + ifun = ifun + 1 + nfgv = nfgv + 1 + iback = ifun - 1 + print*, 'Step is: ',stp + if (stp .eq. one) then + call dcopy(n,z,1,x,1) + else + do 41 i = 1, n + x(i) = stp*d(i) + t(i) + 41 continue + endif + else + task = 'NEW_X' + endif + + return + + end + +c======================= The end of lnsrlb ============================= + + subroutine matupd(n, m, ws, wy, sy, ss, d, r, itail, + + iupdat, col, head, theta, rr, dr, stp, dtd) + + integer n, m, itail, iupdat, col, head + real(8)theta, rr, dr, stp, dtd, d(n), r(n), + + ws(n, m), wy(n, m), sy(m, m), ss(m, m) + +c ************ +c +c Subroutine matupd +c +c This subroutine updates matrices WS and WY, and forms the +c middle matrix in B. +c +c Subprograms called: +c +c Linpack ... dcopy, ddot. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer j,pointr + real(8)ddot + real(8)one + parameter (one=1.0d0) + +c Set pointers for matrices WS and WY. + + if (iupdat .le. m) then + col = iupdat + itail = mod(head+iupdat-2,m) + 1 + else + itail = mod(itail,m) + 1 + head = mod(head,m) + 1 + endif + +c Update matrices WS and WY. + + call dcopy(n,d,1,ws(1,itail),1) + call dcopy(n,r,1,wy(1,itail),1) + +c Set theta=yy/ys. + + theta = rr/dr + +c Form the middle matrix in B. + +c update the upper triangle of SS, +c and the lower triangle of SY: + if (iupdat .gt. m) then +c move old information + do 50 j = 1, col - 1 + call dcopy(j,ss(2,j+1),1,ss(1,j),1) + call dcopy(col-j,sy(j+1,j+1),1,sy(j,j),1) + 50 continue + endif +c add new information: the last row of SY +c and the last column of SS: + pointr = head + do 51 j = 1, col - 1 + sy(col,j) = ddot(n,d,1,wy(1,pointr),1) + ss(j,col) = ddot(n,ws(1,pointr),1,d,1) + pointr = mod(pointr,m) + 1 + 51 continue + if (stp .eq. one) then + ss(col,col) = dtd + else + ss(col,col) = stp*stp*dtd + endif + sy(col,col) = dr + + return + + end + +c======================= The end of matupd ============================= + + subroutine prn1lb(n, m, l, u, x, iprint, itfile, epsmch) + + integer n, m, iprint, itfile + real(8)epsmch, x(n), l(n), u(n) + +c ************ +c +c Subroutine prn1lb +c +c This subroutine prints the input data, initial point, upper and +c lower bounds of each variable, machine precision, as well as +c the headings of the output. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer i + + if (iprint .ge. 0) then + write (6,7001) epsmch + write (6,*) 'N = ',n,' M = ',m + if (iprint .ge. 1) then + write (itfile,2001) epsmch + write (itfile,*)'N = ',n,' M = ',m + write (itfile,9001) + if (iprint .gt. 100) then + write (6,1004) 'L =',(l(i),i = 1,n) + write (6,1004) 'X0 =',(x(i),i = 1,n) + write (6,1004) 'U =',(u(i),i = 1,n) + endif + endif + endif + + 1004 format (/,a4, 1p, 6(1x,d11.4),/,(4x,1p,6(1x,d11.4))) + 2001 format ('RUNNING THE L-BFGS-B CODE',/,/, + + 'it = iteration number',/, + + 'nf = number of function evaluations',/, + + 'nint = number of segments explored during the Cauchy search',/, + + 'nact = number of active bounds at the generalized Cauchy point' + + ,/, + + 'sub = manner in which the subspace minimization terminated:' + + ,/,' con = converged, bnd = a bound was reached',/, + + 'itls = number of iterations performed in the line search',/, + + 'stepl = step length used',/, + + 'tstep = norm of the displacement (total step)',/, + + 'projg = norm of the projected gradient',/, + + 'f = function value',/,/, + + ' * * *',/,/, + + 'Machine precision =',1p,d10.3) + 7001 format ('RUNNING THE L-BFGS-B CODE',/,/, + + ' * * *',/,/, + + 'Machine precision =',1p,d10.3) + 9001 format (/,3x,'it',3x,'nf',2x,'nint',2x,'nact',2x,'sub',2x,'itls', + + 2x,'stepl',4x,'tstep',5x,'projg',8x,'f') + + return + + end + +c======================= The end of prn1lb ============================= + + subroutine prn2lb(n, x, f, g, iprint, itfile, iter, nfgv, nact, + + sbgnrm, nint, word, iword, iback, stp, xstep) + + character(LEN=3) word + integer n, iprint, itfile, iter, nfgv, nact, nint, + + iword, iback + real(8)f, sbgnrm, stp, xstep, x(n), g(n) + +c ************ +c +c Subroutine prn2lb +c +c This subroutine prints out new information after a successful +c line search. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer i,imod + +c 'word' records the status of subspace solutions. + if (iword .eq. 0) then +c the subspace minimization converged. + word = 'con' + else if (iword .eq. 1) then +c the subspace minimization stopped at a bound. + word = 'bnd' + else if (iword .eq. 5) then +c the truncated Newton step has been used. + word = 'TNT' + else + word = '---' + endif + if (iprint .ge. 99) then + write (6,*) 'LINE SEARCH',iback,' times; norm of step = ',xstep + write (6,2001) iter,f,sbgnrm + print*,'Gradient: ',sbgnrm + if (iprint .gt. 100) then + write (6,1004) 'X =',(x(i), i = 1, n) + write (6,1004) 'G =',(g(i), i = 1, n) + endif + else if (iprint .gt. 0) then + imod = mod(iter,iprint) + if (imod .eq. 0) write (6,2001) iter,f,sbgnrm + print*,'Gradient: ',sbgnrm + endif + if (iprint .ge. 1) write (itfile,3001) + + iter,nfgv,nint,nact,word,iback,stp,xstep,sbgnrm,f + + 1004 format (/,a4, 1p, 6(1x,d11.4),/,(4x,1p,6(1x,d11.4))) + 2001 format + + (/,'At iterate',i5,4x,'f= ',1p,d12.5,4x,'|proj g|= ',1p,d12.5) + 3001 format(2(1x,i4),2(1x,i5),2x,a3,1x,i4,1p,2(2x,d8.1),1p,2(1x,d10.3)) + + return + + end + +c======================= The end of prn2lb ============================= + + subroutine prn3lb(n, x, f, task, iprint, info, itfile, + + iter, nfgv, nintol, nskip, nact, sbgnrm, + + time, nint, word, iback, stp, xstep, k, + + cachyt, sbtime, lnscht) + + character(LEN=60) task + character(LEN=3) word + integer n, iprint, info, itfile, iter, nfgv, nintol, + + nskip, nact, nint, iback, k + real(8)f, sbgnrm, time, stp, xstep, cachyt, sbtime, + + lnscht, x(n) + +c ************ +c +c Subroutine prn3lb +c +c This subroutine prints out information when either a built-in +c convergence test is satisfied or when an error message is +c generated. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer i + + if (task(1:5) .eq. 'ERROR') goto 999 + + if (iprint .ge. 0) then + write (6,3003) + write (6,3004) + write(6,3005) n,iter,nfgv,nintol,nskip,nact,sbgnrm,f + if (iprint .ge. 100) then + write (6,1004) 'X =',(x(i),i = 1,n) + endif + if (iprint .ge. 1) write (6,*) ' F =',f + endif + 999 continue + if (iprint .ge. 0) then + write (6,3009) task + if (info .ne. 0) then + if (info .eq. -1) write (6,9011) + if (info .eq. -2) write (6,9012) + if (info .eq. -3) write (6,9013) + if (info .eq. -4) write (6,9014) + if (info .eq. -5) write (6,9015) + if (info .eq. -6) write (6,*)' Input nbd(',k,') is invalid.' + if (info .eq. -7) + + write (6,*)' l(',k,') > u(',k,'). No feasible solution.' + if (info .eq. -8) write (6,9018) + if (info .eq. -9) write (6,9019) + endif + if (iprint .ge. 1) write (6,3007) cachyt,sbtime,lnscht + write (6,3008) time + if (iprint .ge. 1) then + if (info .eq. -4 .or. info .eq. -9) then + write (itfile,3002) + + iter,nfgv,nint,nact,word,iback,stp,xstep + endif + write (itfile,3009) task + if (info .ne. 0) then + if (info .eq. -1) write (itfile,9011) + if (info .eq. -2) write (itfile,9012) + if (info .eq. -3) write (itfile,9013) + if (info .eq. -4) write (itfile,9014) + if (info .eq. -5) write (itfile,9015) + if (info .eq. -8) write (itfile,9018) + if (info .eq. -9) write (itfile,9019) + endif + write (itfile,3008) time + endif + endif + + 1004 format (/,a4, 1p, 6(1x,d11.4),/,(4x,1p,6(1x,d11.4))) + 3002 format(2(1x,i4),2(1x,i5),2x,a3,1x,i4,1p,2(2x,d8.1),6x,'-',10x,'-') + 3003 format (/, + + ' * * *',/,/, + + 'Tit = total number of iterations',/, + + 'Tnf = total number of function evaluations',/, + + 'Tnint = total number of segments explored during', + + ' Cauchy searches',/, + + 'Skip = number of BFGS updates skipped',/, + + 'Nact = number of active bounds at final generalized', + + ' Cauchy point',/, + + 'Projg = norm of the final projected gradient',/, + + 'F = final function value',/,/, + + ' * * *') + 3004 format (/,3x,'N',3x,'Tit',2x,'Tnf',2x,'Tnint',2x, + + 'Skip',2x,'Nact',5x,'Projg',8x,'F') + 3005 format (i5,2(1x,i4),(1x,i6),(2x,i4),(1x,i5),1p,2(2x,d10.3)) +! 3006 format (i5,2(1x,i4),2(1x,i6),(1x,i4),(1x,i5),7x,'-',10x,'-') + 3007 format (/,' Cauchy time',1p,e10.3,' seconds.',/ + + ' Subspace minimization time',1p,e10.3,' seconds.',/ + + ' Line search time',1p,e10.3,' seconds.') + 3008 format (/,' Total User time',1p,e10.3,' seconds.',/) + 3009 format (/,a60) + 9011 format (/, + +' Matrix in 1st Cholesky factorization in formk is not Pos. Def.') + 9012 format (/, + +' Matrix in 2st Cholesky factorization in formk is not Pos. Def.') + 9013 format (/, + +' Matrix in the Cholesky factorization in formt is not Pos. Def.') + 9014 format (/, + +' Derivative >= 0, backtracking line search impossible.',/, + +' Previous x, f and g restored.',/, + +' Possible causes: 1 error in function or gradient evaluation;',/, + +' 2 rounding errors dominate computation.') + 9015 format (/, + +' Warning: more than 10 function and gradient',/, + +' evaluations in the last line search. Termination',/, + +' may possibly be caused by a bad search direction.') + 9018 format (/,' The triangular system is singular.') + 9019 format (/, + +' Line search cannot locate an adequate point after 20 function',/ + +,' and gradient evaluations. Previous x, f and g restored.',/, + +' Possible causes: 1 error in function or gradient evaluation;',/, + +' 2 rounding error dominate computation.') + + return + + end + +c======================= The end of prn3lb ============================= + + subroutine projgr(n, l, u, nbd, x, g, sbgnrm) + + integer n, nbd(n) + real(8)sbgnrm, x(n), l(n), u(n), g(n) + +c ************ +c +c Subroutine projgr +c +c This subroutine computes the infinity norm of the projected +c gradient. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer i + real(8)gi + real(8)zero + parameter (zero=0.0d0) + + sbgnrm = zero + do 15 i = 1, n + gi = g(i) + if (nbd(i) .ne. 0) then + if (gi .lt. zero) then + if (nbd(i) .ge. 2) gi = max((x(i)-u(i)),gi) + else + if (nbd(i) .le. 2) gi = min((x(i)-l(i)),gi) + endif + endif + sbgnrm = max(sbgnrm,abs(gi)) + 15 continue + + return + + end + +c======================= The end of projgr ============================= + + subroutine subsm(n, m, nsub, ind, l, u, nbd, x, d, ws, wy, theta, + + col, head, iword, wv, wn, iprint, info) + + integer n, m, nsub, col, head, iword, iprint, info, + + ind(nsub), nbd(n) + real(8)theta, + + l(n), u(n), x(n), d(n), + + ws(n, m), wy(n, m), + + wv(2*m), wn(2*m, 2*m) + +c ************ +c +c Subroutine subsm +c +c Given xcp, l, u, r, an index set that specifies +c the active set at xcp, and an l-BFGS matrix B +c (in terms of WY, WS, SY, WT, head, col, and theta), +c this subroutine computes an approximate solution +c of the subspace problem +c +c (P) min Q(x) = r'(x-xcp) + 1/2 (x-xcp)' B (x-xcp) +c +c subject to l<=x<=u +c x_i=xcp_i for all i in A(xcp) +c +c along the subspace unconstrained Newton direction +c +c d = -(Z'BZ)^(-1) r. +c +c The formula for the Newton direction, given the L-BFGS matrix +c and the Sherman-Morrison formula, is +c +c d = (1/theta)r + (1/theta*2) Z'WK^(-1)W'Z r. +c +c where +c K = [-D -Y'ZZ'Y/theta L_a'-R_z' ] +c [L_a -R_z theta*S'AA'S ] +c +c Note that this procedure for computing d differs +c from that described in [1]. One can show that the matrix K is +c equal to the matrix M^[-1]N in that paper. +c +c n is an integer variable. +c On entry n is the dimension of the problem. +c On exit n is unchanged. +c +c m is an integer variable. +c On entry m is the maximum number of variable metric corrections +c used to define the limited memory matrix. +c On exit m is unchanged. +c +c nsub is an integer variable. +c On entry nsub is the number of free variables. +c On exit nsub is unchanged. +c +c ind is an integer array of dimension nsub. +c On entry ind specifies the coordinate indices of free variables. +c On exit ind is unchanged. +c +c l is a real(8)array of dimension n. +c On entry l is the lower bound of x. +c On exit l is unchanged. +c +c u is a real(8)array of dimension n. +c On entry u is the upper bound of x. +c On exit u is unchanged. +c +c nbd is a integer array of dimension n. +c On entry nbd represents the type of bounds imposed on the +c variables, and must be specified as follows: +c nbd(i)=0 if x(i) is unbounded, +c 1 if x(i) has only a lower bound, +c 2 if x(i) has both lower and upper bounds, and +c 3 if x(i) has only an upper bound. +c On exit nbd is unchanged. +c +c x is a real(8)array of dimension n. +c On entry x specifies the Cauchy point xcp. +c On exit x(i) is the minimizer of Q over the subspace of +c free variables. +c +c d is a real(8)array of dimension n. +c On entry d is the reduced gradient of Q at xcp. +c On exit d is the Newton direction of Q. +c +c ws and wy are real(8)arrays; +c theta is a real(8)variable; +c col is an integer variable; +c head is an integer variable. +c On entry they store the information defining the +c limited memory BFGS matrix: +c ws(n,m) stores S, a set of s-vectors; +c wy(n,m) stores Y, a set of y-vectors; +c theta is the scaling factor specifying B_0 = theta I; +c col is the number of variable metric corrections stored; +c head is the location of the 1st s- (or y-) vector in S (or Y). +c On exit they are unchanged. +c +c iword is an integer variable. +c On entry iword is unspecified. +c On exit iword specifies the status of the subspace solution. +c iword = 0 if the solution is in the box, +c 1 if some bound is encountered. +c +c wv is a real(8)working array of dimension 2m. +c +c wn is a real(8)array of dimension 2m x 2m. +c On entry the upper triangle of wn stores the LEL^T factorization +c of the indefinite matrix +c +c K = [-D -Y'ZZ'Y/theta L_a'-R_z' ] +c [L_a -R_z theta*S'AA'S ] +c where E = [-I 0] +c [ 0 I] +c On exit wn is unchanged. +c +c iprint is an INTEGER variable that must be set by the user. +c It controls the frequency and type of output generated: +c iprint<0 no output is generated; +c iprint=0 print only one line at the last iteration; +c 0100 print details of every iteration including x and g; +c When iprint > 0, the file iterate.dat will be created to +c summarize the iteration. +c +c info is an integer variable. +c On entry info is unspecified. +c On exit info = 0 for normal return, +c = nonzero for abnormal return +c when the matrix K is ill-conditioned. +c +c Subprograms called: +c +c Linpack dtrsl. +c +c +c References: +c +c [1] R. H. Byrd, P. Lu, J. Nocedal and C. Zhu, ``A limited +c memory algorithm for bound constrained optimization'', +c SIAM J. Scientific Computing 16 (1995), no. 5, pp. 1190--1208. +c +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer pointr,m2,col2,ibd,jy,js,i,j,k + real(8)alpha,dk,temp1,temp2 + real(8)one,zero + parameter (one=1.0d0,zero=0.0d0) + + if (nsub .le. 0) return + if (iprint .ge. 99) write (6,1001) + +c Compute wv = W'Zd. + + pointr = head + do 20 i = 1, col + temp1 = zero + temp2 = zero + do 10 j = 1, nsub + k = ind(j) + temp1 = temp1 + wy(k,pointr)*d(j) + temp2 = temp2 + ws(k,pointr)*d(j) + 10 continue + wv(i) = temp1 + wv(col + i) = theta*temp2 + pointr = mod(pointr,m) + 1 + 20 continue + +c Compute wv:=K^(-1)wv. + + m2 = 2*m + col2 = 2*col + call dtrsl(wn,m2,col2,wv,11,info) + if (info .ne. 0) return + do 25 i = 1, col + wv(i) = -wv(i) + 25 continue + call dtrsl(wn,m2,col2,wv,01,info) + if (info .ne. 0) return + +c Compute d = (1/theta)d + (1/theta**2)Z'W wv. + + pointr = head + do 40 jy = 1, col + js = col + jy + do 30 i = 1, nsub + k = ind(i) + d(i) = d(i) + wy(k,pointr)*wv(jy)/theta + + + ws(k,pointr)*wv(js) + 30 continue + pointr = mod(pointr,m) + 1 + 40 continue + do 50 i = 1, nsub + d(i) = d(i)/theta + 50 continue + +c Backtrack to the feasible region. + + alpha = one + temp1 = alpha + do 60 i = 1, nsub + k = ind(i) + dk = d(i) + if (nbd(k) .ne. 0) then + if (dk .lt. zero .and. nbd(k) .le. 2) then + temp2 = l(k) - x(k) + if (temp2 .ge. zero) then + temp1 = zero + else if (dk*alpha .lt. temp2) then + temp1 = temp2/dk + endif + else if (dk .gt. zero .and. nbd(k) .ge. 2) then + temp2 = u(k) - x(k) + if (temp2 .le. zero) then + temp1 = zero + else if (dk*alpha .gt. temp2) then + temp1 = temp2/dk + endif + endif + if (temp1 .lt. alpha) then + alpha = temp1 + ibd = i + endif + endif + 60 continue + + if (alpha .lt. one) then + dk = d(ibd) + k = ind(ibd) + if (dk .gt. zero) then + x(k) = u(k) + d(ibd) = zero + else if (dk .lt. zero) then + x(k) = l(k) + d(ibd) = zero + endif + endif + do 70 i = 1, nsub + k = ind(i) + x(k) = x(k) + alpha*d(i) + 70 continue + + if (iprint .ge. 99) then + if (alpha .lt. one) then + write (6,1002) alpha + else + write (6,*) 'SM solution inside the box' + end if + if (iprint .gt.100) write (6,1003) (x(i),i=1,n) + endif + + if (alpha .lt. one) then + iword = 1 + else + iword = 0 + endif + if (iprint .ge. 99) write (6,1004) + + 1001 format (/,'----------------SUBSM entered-----------------',/) + 1002 format ( 'ALPHA = ',f7.5,' backtrack to the BOX') + 1003 format ('Subspace solution X = ',/,(4x,1p,6(1x,d11.4))) + 1004 format (/,'----------------exit SUBSM --------------------',/) + + return + + end + +c====================== The end of subsm =============================== + + subroutine dcsrch(f,g,stp,ftol,gtol,xtol,stpmin,stpmax, + + task,isave,dsave) + character*(*) task + integer isave(2) + real(8)f,g,stp,ftol,gtol,xtol,stpmin,stpmax + real(8)dsave(13) +c ********** +c +c Subroutine dcsrch +c +c This subroutine finds a step that satisfies a sufficient +c decrease condition and a curvature condition. +c +c Each call of the subroutine updates an interval with +c endpoints stx and sty. The interval is initially chosen +c so that it contains a minimizer of the modified function +c +c psi(stp) = f(stp) - f(0) - ftol*stp*f'(0). +c +c If psi(stp) <= 0 and f'(stp) >= 0 for some step, then the +c interval is chosen so that it contains a minimizer of f. +c +c The algorithm is designed to find a step that satisfies +c the sufficient decrease condition +c +c f(stp) <= f(0) + ftol*stp*f'(0), +c +c and the curvature condition +c +c abs(f'(stp)) <= gtol*abs(f'(0)). +c +c If ftol is less than gtol and if, for example, the function +c is bounded below, then there is always a step which satisfies +c both conditions. +c +c If no step can be found that satisfies both conditions, then +c the algorithm stops with a warning. In this case stp only +c satisfies the sufficient decrease condition. +c +c A typical invocation of dcsrch has the following outline: +c +c task = 'START' +c 10 continue +c call dcsrch( ... ) +c if (task .eq. 'FG') then +c Evaluate the function and the gradient at stp +c goto 10 +c end if +c +c NOTE: The user must no alter work arrays between calls. +c +c The subroutine statement is +c +c subroutine dcsrch(f,g,stp,ftol,gtol,xtol,stpmin,stpmax, +c task,isave,dsave) +c where +c +c f is a real(8)variable. +c On initial entry f is the value of the function at 0. +c On subsequent entries f is the value of the +c function at stp. +c On exit f is the value of the function at stp. +c +c g is a real(8)variable. +c On initial entry g is the derivative of the function at 0. +c On subsequent entries g is the derivative of the +c function at stp. +c On exit g is the derivative of the function at stp. +c +c stp is a real(8)variable. +c On entry stp is the current estimate of a satisfactory +c step. On initial entry, a positive initial estimate +c must be provided. +c On exit stp is the current estimate of a satisfactory step +c if task = 'FG'. If task = 'CONV' then stp satisfies +c the sufficient decrease and curvature condition. +c +c ftol is a real(8)variable. +c On entry ftol specifies a nonnegative tolerance for the +c sufficient decrease condition. +c On exit ftol is unchanged. +c +c gtol is a real(8)variable. +c On entry gtol specifies a nonnegative tolerance for the +c curvature condition. +c On exit gtol is unchanged. +c +c xtol is a real(8)variable. +c On entry xtol specifies a nonnegative relative tolerance +c for an acceptable step. The subroutine exits with a +c warning if the relative difference between sty and stx +c is less than xtol. +c On exit xtol is unchanged. +c +c stpmin is a real(8)variable. +c On entry stpmin is a nonnegative lower bound for the step. +c On exit stpmin is unchanged. +c +c stpmax is a real(8)variable. +c On entry stpmax is a nonnegative upper bound for the step. +c On exit stpmax is unchanged. +c +c task is a character variable of length at least 60. +c On initial entry task must be set to 'START'. +c On exit task indicates the required action: +c +c If task(1:2) = 'FG' then evaluate the function and +c derivative at stp and call dcsrch again. +c +c If task(1:4) = 'CONV' then the search is successful. +c +c If task(1:4) = 'WARN' then the subroutine is not able +c to satisfy the convergence conditions. The exit value of +c stp contains the best point found during the search. +c +c If task(1:5) = 'ERROR' then there is an error in the +c input arguments. +c +c On exit with convergence, a warning or an error, the +c variable task contains additional information. +c +c isave is an integer work array of dimension 2. +c +c dsave is a real(8)work array of dimension 13. +c +c Subprograms called +c +c MINPACK-2 ... dcstep +c +c MINPACK-1 Project. June 1983. +c Argonne National Laboratory. +c Jorge J. More' and David J. Thuente. +c +c MINPACK-2 Project. October 1993. +c Argonne National Laboratory and University of Minnesota. +c Brett M. Averick, Richard G. Carter, and Jorge J. More'. +c +c ********** + real(8)zero,p5,p66 + parameter(zero=0.0d0,p5=0.5d0,p66=0.66d0) + real(8)xtrapl,xtrapu + parameter(xtrapl=1.1d0,xtrapu=4.0d0) + + logical brackt + integer stage + real(8)finit,ftest,fm,fx,fxm,fy,fym,ginit,gtest, + + gm,gx,gxm,gy,gym,stx,sty,stmin,stmax,width,width1 + +c Initialization block. + + if (task(1:5) .eq. 'START') then + +c Check the input arguments for errors. + + if (stp .lt. stpmin) task = 'ERROR: STP .LT. STPMIN' + if (stp .gt. stpmax) task = 'ERROR: STP .GT. STPMAX' + if (g .ge. zero) task = 'ERROR: INITIAL G .GE. ZERO' + if (ftol .lt. zero) task = 'ERROR: FTOL .LT. ZERO' + if (gtol .lt. zero) task = 'ERROR: GTOL .LT. ZERO' + if (xtol .lt. zero) task = 'ERROR: XTOL .LT. ZERO' + if (stpmin .lt. zero) task = 'ERROR: STPMIN .LT. ZERO' + if (stpmax .lt. stpmin) task = 'ERROR: STPMAX .LT. STPMIN' + +c Exit if there are errors on input. + + if (task(1:5) .eq. 'ERROR') return + +c Initialize local variables. + + brackt = .false. + stage = 1 + finit = f + ginit = g + gtest = ftol*ginit + width = stpmax - stpmin + width1 = width/p5 + +c The variables stx, fx, gx contain the values of the step, +c function, and derivative at the best step. +c The variables sty, fy, gy contain the value of the step, +c function, and derivative at sty. +c The variables stp, f, g contain the values of the step, +c function, and derivative at stp. + + stx = zero + fx = finit + gx = ginit + sty = zero + fy = finit + gy = ginit + stmin = zero + stmax = stp + xtrapu*stp + task = 'FG' + + goto 1000 + + else + +c Restore local variables. + + if (isave(1) .eq. 1) then + brackt = .true. + else + brackt = .false. + endif + stage = isave(2) + ginit = dsave(1) + gtest = dsave(2) + gx = dsave(3) + gy = dsave(4) + finit = dsave(5) + fx = dsave(6) + fy = dsave(7) + stx = dsave(8) + sty = dsave(9) + stmin = dsave(10) + stmax = dsave(11) + width = dsave(12) + width1 = dsave(13) + + endif + +c If psi(stp) <= 0 and f'(stp) >= 0 for some step, then the +c algorithm enters the second stage. + + ftest = finit + stp*gtest + if (stage .eq. 1 .and. f .le. ftest .and. g .ge. zero) + + stage = 2 + +c Test for warnings. + + if (brackt .and. (stp .le. stmin .or. stp .ge. stmax)) + + task = 'WARNING: ROUNDING ERRORS PREVENT PROGRESS' + if (brackt .and. stmax - stmin .le. xtol*stmax) + + task = 'WARNING: XTOL TEST SATISFIED' + if (stp .eq. stpmax .and. f .le. ftest .and. g .le. gtest) + + task = 'WARNING: STP = STPMAX' + if (stp .eq. stpmin .and. (f .gt. ftest .or. g .ge. gtest)) + + task = 'WARNING: STP = STPMIN' + +c Test for convergence. + + if (f .le. ftest .and. abs(g) .le. gtol*(-ginit)) + + task = 'CONVERGENCE' + +c Test for termination. + + if (task(1:4) .eq. 'WARN' .or. task(1:4) .eq. 'CONV') goto 1000 + +c A modified function is used to predict the step during the +c first stage if a lower function value has been obtained but +c the decrease is not sufficient. + + if (stage .eq. 1 .and. f .le. fx .and. f .gt. ftest) then + +c Define the modified function and derivative values. + + fm = f - stp*gtest + fxm = fx - stx*gtest + fym = fy - sty*gtest + gm = g - gtest + gxm = gx - gtest + gym = gy - gtest + +c Call dcstep to update stx, sty, and to compute the new step. + + call dcstep(stx,fxm,gxm,sty,fym,gym,stp,fm,gm, + + brackt,stmin,stmax) + +c Reset the function and derivative values for f. + + fx = fxm + stx*gtest + fy = fym + sty*gtest + gx = gxm + gtest + gy = gym + gtest + + else + +c Call dcstep to update stx, sty, and to compute the new step. + + call dcstep(stx,fx,gx,sty,fy,gy,stp,f,g, + + brackt,stmin,stmax) + + endif + +c Decide if a bisection step is needed. + + if (brackt) then + if (abs(sty-stx) .ge. p66*width1) stp = stx + p5*(sty - stx) + width1 = width + width = abs(sty-stx) + endif + +c Set the minimum and maximum steps allowed for stp. + + if (brackt) then + stmin = min(stx,sty) + stmax = max(stx,sty) + else + stmin = stp + xtrapl*(stp - stx) + stmax = stp + xtrapu*(stp - stx) + endif + +c Force the step to be within the bounds stpmax and stpmin. + + stp = max(stp,stpmin) + stp = min(stp,stpmax) + +c If further progress is not possible, let stp be the best +c point obtained during the search. + + if (brackt .and. (stp .le. stmin .or. stp .ge. stmax) + + .or. (brackt .and. stmax-stmin .le. xtol*stmax)) stp = stx + +c Obtain another function and derivative. + + task = 'FG' + + 1000 continue + +c Save local variables. + + if (brackt) then + isave(1) = 1 + else + isave(1) = 0 + endif + isave(2) = stage + dsave(1) = ginit + dsave(2) = gtest + dsave(3) = gx + dsave(4) = gy + dsave(5) = finit + dsave(6) = fx + dsave(7) = fy + dsave(8) = stx + dsave(9) = sty + dsave(10) = stmin + dsave(11) = stmax + dsave(12) = width + dsave(13) = width1 + + end + +c====================== The end of dcsrch ============================== + + subroutine dcstep(stx,fx,dx,sty,fy,dy,stp,fp,dp,brackt, + + stpmin,stpmax) + logical brackt + real(8)stx,fx,dx,sty,fy,dy,stp,fp,dp,stpmin,stpmax +c ********** +c +c Subroutine dcstep +c +c This subroutine computes a safeguarded step for a search +c procedure and updates an interval that contains a step that +c satisfies a sufficient decrease and a curvature condition. +c +c The parameter stx contains the step with the least function +c value. If brackt is set to .true. then a minimizer has +c been bracketed in an interval with endpoints stx and sty. +c The parameter stp contains the current step. +c The subroutine assumes that if brackt is set to .true. then +c +c min(stx,sty) < stp < max(stx,sty), +c +c and that the derivative at stx is negative in the direction +c of the step. +c +c The subroutine statement is +c +c subroutine dcstep(stx,fx,dx,sty,fy,dy,stp,fp,dp,brackt, +c stpmin,stpmax) +c +c where +c +c stx is a real(8)variable. +c On entry stx is the best step obtained so far and is an +c endpoint of the interval that contains the minimizer. +c On exit stx is the updated best step. +c +c fx is a real(8)variable. +c On entry fx is the function at stx. +c On exit fx is the function at stx. +c +c dx is a real(8)variable. +c On entry dx is the derivative of the function at +c stx. The derivative must be negative in the direction of +c the step, that is, dx and stp - stx must have opposite +c signs. +c On exit dx is the derivative of the function at stx. +c +c sty is a real(8)variable. +c On entry sty is the second endpoint of the interval that +c contains the minimizer. +c On exit sty is the updated endpoint of the interval that +c contains the minimizer. +c +c fy is a real(8)variable. +c On entry fy is the function at sty. +c On exit fy is the function at sty. +c +c dy is a real(8)variable. +c On entry dy is the derivative of the function at sty. +c On exit dy is the derivative of the function at the exit sty. +c +c stp is a real(8)variable. +c On entry stp is the current step. If brackt is set to .true. +c then on input stp must be between stx and sty. +c On exit stp is a new trial step. +c +c fp is a real(8)variable. +c On entry fp is the function at stp +c On exit fp is unchanged. +c +c dp is a real(8)variable. +c On entry dp is the the derivative of the function at stp. +c On exit dp is unchanged. +c +c brackt is an logical variable. +c On entry brackt specifies if a minimizer has been bracketed. +c Initially brackt must be set to .false. +c On exit brackt specifies if a minimizer has been bracketed. +c When a minimizer is bracketed brackt is set to .true. +c +c stpmin is a real(8)variable. +c On entry stpmin is a lower bound for the step. +c On exit stpmin is unchanged. +c +c stpmax is a real(8)variable. +c On entry stpmax is an upper bound for the step. +c On exit stpmax is unchanged. +c +c MINPACK-1 Project. June 1983 +c Argonne National Laboratory. +c Jorge J. More' and David J. Thuente. +c +c MINPACK-2 Project. October 1993. +c Argonne National Laboratory and University of Minnesota. +c Brett M. Averick and Jorge J. More'. +c +c ********** + real(8)zero,p66,two,three + parameter(zero=0.0d0,p66=0.66d0,two=2.0d0,three=3.0d0) + + real(8)gamma,p,q,r,s,sgnd,stpc,stpf,stpq,theta + + sgnd = dp*(dx/abs(dx)) + +c First case: A higher function value. The minimum is bracketed. +c If the cubic step is closer to stx than the quadratic step, the +c cubic step is taken, otherwise the average of the cubic and +c quadratic steps is taken. + + if (fp .gt. fx) then + theta = three*(fx - fp)/(stp - stx) + dx + dp + s = max(abs(theta),abs(dx),abs(dp)) + gamma = s*sqrt((theta/s)**2 - (dx/s)*(dp/s)) + if (stp .lt. stx) gamma = -gamma + p = (gamma - dx) + theta + q = ((gamma - dx) + gamma) + dp + r = p/q + stpc = stx + r*(stp - stx) + stpq = stx + ((dx/((fx - fp)/(stp - stx) + dx))/two)* + + (stp - stx) + if (abs(stpc-stx) .lt. abs(stpq-stx)) then + stpf = stpc + else + stpf = stpc + (stpq - stpc)/two + endif + brackt = .true. + +c Second case: A lower function value and derivatives of opposite +c sign. The minimum is bracketed. If the cubic step is farther from +c stp than the secant step, the cubic step is taken, otherwise the +c secant step is taken. + + else if (sgnd .lt. zero) then + theta = three*(fx - fp)/(stp - stx) + dx + dp + s = max(abs(theta),abs(dx),abs(dp)) + gamma = s*sqrt((theta/s)**2 - (dx/s)*(dp/s)) + if (stp .gt. stx) gamma = -gamma + p = (gamma - dp) + theta + q = ((gamma - dp) + gamma) + dx + r = p/q + stpc = stp + r*(stx - stp) + stpq = stp + (dp/(dp - dx))*(stx - stp) + if (abs(stpc-stp) .gt. abs(stpq-stp)) then + stpf = stpc + else + stpf = stpq + endif + brackt = .true. + +c Third case: A lower function value, derivatives of the same sign, +c and the magnitude of the derivative decreases. + + else if (abs(dp) .lt. abs(dx)) then + +c The cubic step is computed only if the cubic tends to infinity +c in the direction of the step or if the minimum of the cubic +c is beyond stp. Otherwise the cubic step is defined to be the +c secant step. + + theta = three*(fx - fp)/(stp - stx) + dx + dp + s = max(abs(theta),abs(dx),abs(dp)) + +c The case gamma = 0 only arises if the cubic does not tend +c to infinity in the direction of the step. + + gamma = s*sqrt(max(zero,(theta/s)**2-(dx/s)*(dp/s))) + if (stp .gt. stx) gamma = -gamma + p = (gamma - dp) + theta + q = (gamma + (dx - dp)) + gamma + r = p/q + if (r .lt. zero .and. gamma .ne. zero) then + stpc = stp + r*(stx - stp) + else if (stp .gt. stx) then + stpc = stpmax + else + stpc = stpmin + endif + stpq = stp + (dp/(dp - dx))*(stx - stp) + + if (brackt) then + +c A minimizer has been bracketed. If the cubic step is +c closer to stp than the secant step, the cubic step is +c taken, otherwise the secant step is taken. + + if (abs(stpc-stp) .lt. abs(stpq-stp)) then + stpf = stpc + else + stpf = stpq + endif + if (stp .gt. stx) then + stpf = min(stp+p66*(sty-stp),stpf) + else + stpf = max(stp+p66*(sty-stp),stpf) + endif + else + +c A minimizer has not been bracketed. If the cubic step is +c farther from stp than the secant step, the cubic step is +c taken, otherwise the secant step is taken. + + if (abs(stpc-stp) .gt. abs(stpq-stp)) then + stpf = stpc + else + stpf = stpq + endif + stpf = min(stpmax,stpf) + stpf = max(stpmin,stpf) + endif + +c Fourth case: A lower function value, derivatives of the same sign, +c and the magnitude of the derivative does not decrease. If the +c minimum is not bracketed, the step is either stpmin or stpmax, +c otherwise the cubic step is taken. + + else + if (brackt) then + theta = three*(fp - fy)/(sty - stp) + dy + dp + s = max(abs(theta),abs(dy),abs(dp)) + gamma = s*sqrt((theta/s)**2 - (dy/s)*(dp/s)) + if (stp .gt. sty) gamma = -gamma + p = (gamma - dp) + theta + q = ((gamma - dp) + gamma) + dy + r = p/q + stpc = stp + r*(sty - stp) + stpf = stpc + else if (stp .gt. stx) then + stpf = stpmax + else + stpf = stpmin + endif + endif + +c Update the interval which contains a minimizer. + + if (fp .gt. fx) then + sty = stp + fy = fp + dy = dp + else + if (sgnd .lt. zero) then + sty = stx + fy = fx + dy = dx + endif + stx = stp + fx = fp + dx = dp + endif + +c Compute the new step. + + stp = stpf + + end + +c====================== The end of dcstep ============================== + + subroutine timer(ttime) + real(8)ttime +c ********* +c +c Subroutine timer +c +c This subroutine is used to determine user time. In a typical +c application, the user time for a code segment requires calls +c to subroutine timer to determine the initial and final time. +c +c The subroutine statement is +c +c subroutine timer(ttime) +c +c where +c +c ttime is an output variable which specifies the user time. +c +c Argonne National Laboratory and University of Minnesota. +c MINPACK-2 Project. +c +c Modified October 1990 by Brett M. Averick. +c +c ********** + real tarray(2) + +c The first element of the array tarray specifies user time + +!ibm temp = etime(tarray) + tarray=0. ! GB just to initialize + ttime = dble(tarray(1)) + + return + + end + +c====================== The end of timer =============================== + + real(8)function dnrm2(n,x,incx) + integer n,incx + real(8)x(n) +c ********** +c +c Function dnrm2 +c +c Given a vector x of length n, this function calculates the +c Euclidean norm of x with stride incx. +c +c The function statement is +c +c real(8)function dnrm2(n,x,incx) +c +c where +c +c n is a positive integer input variable. +c +c x is an input array of length n. +c +c incx is a positive integer variable that specifies the +c stride of the vector. +c +c Subprograms called +c +c FORTRAN-supplied ... abs, max, sqrt +c +c MINPACK-2 Project. February 1991. +c Argonne National Laboratory. +c Brett M. Averick. +c +c ********** + integer i + real(8)scale + + dnrm2 = 0.0d0 + scale = 0.0d0 + + do 10 i = 1, n, incx + scale = max(scale, abs(x(i))) + 10 continue + + if (scale .eq. 0.0d0) return + + do 20 i = 1, n, incx + dnrm2 = dnrm2 + (x(i)/scale)**2 + 20 continue + + dnrm2 = scale*sqrt(dnrm2) + + + return + + end + +c====================== The end of dnrm2 =============================== + + real(8)function dpmeps() +c ********** +c +c Subroutine dpeps +c +c This subroutine computes the machine precision parameter +c dpmeps as the smallest floating point number such that +c 1 + dpmeps differs from 1. +c +c This subroutine is based on the subroutine machar described in +c +c W. J. Cody, +c MACHAR: A subroutine to dynamically determine machine parameters, +c ACM Transactions on Mathematical Software, 14, 1988, pages 303-311. +c +c The subroutine statement is: +c +c subroutine dpeps(dpmeps) +c +c where +c +c dpmeps is a real(8)variable. +c On entry dpmeps need not be specified. +c On exit dpmeps is the machine precision. +c +c MINPACK-2 Project. February 1991. +c Argonne National Laboratory and University of Minnesota. +c Brett M. Averick. +c +c ******* + integer i,ibeta,irnd,it,itemp,negep + real(8)a,b,beta,betain,betah,temp,tempa,temp1, + + zero,one,two + data zero,one,two /0.0d0,1.0d0,2.0d0/ + +c determine ibeta, beta ala malcolm. + + a = one + b = one + 10 continue + a = a + a + temp = a + one + temp1 = temp - a + if (temp1 - one .eq. zero) go to 10 + 20 continue + b = b + b + temp = a + b + itemp = int(temp - a) + if (itemp .eq. 0) go to 20 + ibeta = itemp + beta = dble(ibeta) + +c determine it, irnd. + + it = 0 + b = one + 30 continue + it = it + 1 + b = b * beta + temp = b + one + temp1 = temp - b + if (temp1 - one .eq. zero) go to 30 + irnd = 0 + betah = beta/two + temp = a + betah + if (temp - a .ne. zero) irnd = 1 + tempa = a + beta + temp = tempa + betah + if ((irnd .eq. 0) .and. (temp - tempa .ne. zero)) irnd = 2 + +c determine dpmeps. + + negep = it + 3 + betain = one/beta + a = one + do 40 i = 1, negep + a = a*betain + 40 continue + 50 continue + temp = one + a + if (temp - one .ne. zero) go to 60 + a = a*beta + go to 50 + 60 continue + dpmeps = a + if ((ibeta .eq. 2) .or. (irnd .eq. 0)) go to 70 + a = (a*(one + a))/two + temp = one + a + if (temp - one .ne. zero) dpmeps = a + + 70 return + + end + +c====================== The end of dpmeps ============================== + + subroutine daxpy(n,da,dx,incx,dy,incy) +c +c constant times a vector plus a vector. +c uses unrolled loops for increments equal to one. +c jack dongarra, linpack, 3/11/78. +c +!sd real(8)dx(1),dy(1),da + integer i,incx,incy,ix,iy,m,mp1,n + real(8)dx(n),dy(n),da +c + if(n.le.0)return + if (da .eq. 0.0d0) return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + dy(iy) = dy(iy) + da*dx(ix) + ix = ix + incx + iy = iy + incy + 10 continue + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,4) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dy(i) = dy(i) + da*dx(i) + 30 continue + if( n .lt. 4 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,4 + dy(i) = dy(i) + da*dx(i) + dy(i + 1) = dy(i + 1) + da*dx(i + 1) + dy(i + 2) = dy(i + 2) + da*dx(i + 2) + dy(i + 3) = dy(i + 3) + da*dx(i + 3) + 50 continue + return + end + +c====================== The end of daxpy =============================== + + subroutine dcopy(n,dx,incx,dy,incy) +c +c copies a vector, x, to a vector, y. +c uses unrolled loops for increments equal to one. +c jack dongarra, linpack, 3/11/78. +c +!sd real(8)dx(1),dy(1) + integer i,incx,incy,ix,iy,m,mp1,n + real(8)dx(n),dy(n) +c + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + dy(iy) = dx(ix) + ix = ix + incx + iy = iy + incy + 10 continue + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,7) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dy(i) = dx(i) + 30 continue + if( n .lt. 7 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,7 + dy(i) = dx(i) + dy(i + 1) = dx(i + 1) + dy(i + 2) = dx(i + 2) + dy(i + 3) = dx(i + 3) + dy(i + 4) = dx(i + 4) + dy(i + 5) = dx(i + 5) + dy(i + 6) = dx(i + 6) + 50 continue + return + end + +c====================== The end of dcopy =============================== + + real(8)function ddot(n,dx,incx,dy,incy) +c +c forms the dot product of two vectors. +c uses unrolled loops for increments equal to one. +c jack dongarra, linpack, 3/11/78. +c +!sd real(8)dx(1),dy(1),dtemp + integer i,incx,incy,ix,iy,m,mp1,n + real(8)dx(n),dy(n),dtemp +c + ddot = 0.0d0 + dtemp = 0.0d0 + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + dtemp = dtemp + dx(ix)*dy(iy) + ix = ix + incx + iy = iy + incy + 10 continue + ddot = dtemp + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,5) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dtemp = dtemp + dx(i)*dy(i) + 30 continue + if( n .lt. 5 ) go to 60 + 40 mp1 = m + 1 + do 50 i = mp1,n,5 + dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) + + * dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4) + 50 continue + 60 ddot = dtemp + return + end + +c====================== The end of ddot ================================ + + subroutine dpofa(a,lda,n,info) + integer lda,n,info +! real(8)a(lda,1) + real(8)a(lda,lda) +c +c dpofa factors a real(8)symmetric positive definite +c matrix. +c +c dpofa is usually called by dpoco, but it can be called +c directly with a saving in time if rcond is not needed. +c (time for dpoco) = (1 + 18/n)*(time for dpofa) . +c +c on entry +c +c a real*8(lda, n) +c the symmetric matrix to be factored. only the +c diagonal and upper triangle are used. +c +c lda integer +c the leading dimension of the array a . +c +c n integer +c the order of the matrix a . +c +c on return +c +c a an upper triangular matrix r so that a = trans(r)*r +c where trans(r) is the transpose. +c the strict lower triangle is unaltered. +c if info .ne. 0 , the factorization is not complete. +c +c info integer +c = 0 for normal return. +c = k signals an error condition. the leading minor +c of order k is not positive definite. +c +c linpack. this version dated 08/14/78 . +c cleve moler, university of new mexico, argonne national lab. +c +c subroutines and functions +c +c blas ddot +c fortran sqrt +c +c internal variables +c + real(8)ddot,t + real(8)s + integer j,jm1,k +c begin block with ...exits to 40 +c +c + do 30 j = 1, n + info = j + s = 0.0d0 + jm1 = j - 1 + if (jm1 .lt. 1) go to 20 + do 10 k = 1, jm1 + t = a(k,j) - ddot(k-1,a(1,k),1,a(1,j),1) + t = t/a(k,k) + a(k,j) = t + s = s + t*t + 10 continue + 20 continue + s = a(j,j) - s +c ......exit + if (s .le. 0.0d0) go to 40 + a(j,j) = sqrt(s) + 30 continue + info = 0 + 40 continue + return + end + +c====================== The end of dpofa =============================== + + subroutine dscal(n,da,dx,incx) +c +c scales a vector by a constant. +c uses unrolled loops for increment equal to one. +c jack dongarra, linpack, 3/11/78. +c modified 3/93 to return if incx .le. 0. +c +!sd real(8)da,dx(1) + integer i,incx,m,mp1,n,nincx + real(8)da,dx(n) +c + if( n.le.0 .or. incx.le.0 )return + if(incx.eq.1)go to 20 +c +c code for increment not equal to 1 +c + nincx = n*incx + do 10 i = 1,nincx,incx + dx(i) = da*dx(i) + 10 continue + return +c +c code for increment equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,5) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dx(i) = da*dx(i) + 30 continue + if( n .lt. 5 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,5 + dx(i) = da*dx(i) + dx(i + 1) = da*dx(i + 1) + dx(i + 2) = da*dx(i + 2) + dx(i + 3) = da*dx(i + 3) + dx(i + 4) = da*dx(i + 4) + 50 continue + return + end + +c====================== The end of dscal =============================== + + subroutine dtrsl(t,ldt,n,b,job,info) + integer ldt,n,job,info +!! real(8)t(ldt,1),b(1) + real(8)t(ldt,ldt),b(ldt) +c +c +c dtrsl solves systems of the form +c +c t * x = b +c or +c trans(t) * x = b +c +c where t is a triangular matrix of order n. here trans(t) +c denotes the transpose of the matrix t. +c +c on entry +c +c t real*8(ldt,n) +c t contains the matrix of the system. the zero +c elements of the matrix are not referenced, and +c the corresponding elements of the array can be +c used to store other information. +c +c ldt integer +c ldt is the leading dimension of the array t. +c +c n integer +c n is the order of the system. +c +c b real*8(n). +c b contains the right hand side of the system. +c +c job integer +c job specifies what kind of system is to be solved. +c if job is +c +c 00 solve t*x=b, t lower triangular, +c 01 solve t*x=b, t upper triangular, +c 10 solve trans(t)*x=b, t lower triangular, +c 11 solve trans(t)*x=b, t upper triangular. +c +c on return +c +c b b contains the solution, if info .eq. 0. +c otherwise b is unaltered. +c +c info integer +c info contains zero if the system is nonsingular. +c otherwise info contains the index of +c the first zero diagonal element of t. +c +c linpack. this version dated 08/14/78 . +c g. w. stewart, university of maryland, argonne national lab. +c +c subroutines and functions +c +c blas daxpy,ddot +c fortran mod +c +c internal variables +c + real(8) ddot,temp + integer case,j,jj +c +c begin block permitting ...exits to 150 +c +c check for zero diagonal elements. +c + do 10 info = 1, n +c ......exit + if (t(info,info) .eq. 0.0d0) go to 150 + 10 continue + info = 0 +c +c determine the task and go to it. +c + case = 1 + if (mod(job,10) .ne. 0) case = 2 + if (mod(job,100)/10 .ne. 0) case = case + 2 + go to (20,50,80,110), case +c +c solve t*x=b for t lower triangular +c + 20 continue + b(1) = b(1)/t(1,1) + if (n .lt. 2) go to 40 + do 30 j = 2, n + temp = -b(j-1) + call daxpy(n-j+1,temp,t(j,j-1),1,b(j),1) + b(j) = b(j)/t(j,j) + 30 continue + 40 continue + go to 140 +c +c solve t*x=b for t upper triangular. +c + 50 continue + b(n) = b(n)/t(n,n) + if (n .lt. 2) go to 70 + do 60 jj = 2, n + j = n - jj + 1 + temp = -b(j+1) + call daxpy(j,temp,t(1,j+1),1,b(1),1) + b(j) = b(j)/t(j,j) + 60 continue + 70 continue + go to 140 +c +c solve trans(t)*x=b for t lower triangular. +c + 80 continue + b(n) = b(n)/t(n,n) + if (n .lt. 2) go to 100 + do 90 jj = 2, n + j = n - jj + 1 + b(j) = b(j) - ddot(jj-1,t(j+1,j),1,b(j+1),1) + b(j) = b(j)/t(j,j) + 90 continue + 100 continue + go to 140 +c +c solve trans(t)*x=b for t upper triangular. +c + 110 continue + b(1) = b(1)/t(1,1) + if (n .lt. 2) go to 130 + do 120 j = 2, n + b(j) = b(j) - ddot(j-1,t(1,j),1,b(1),1) + b(j) = b(j)/t(j,j) + 120 continue + 130 continue + 140 continue + 150 continue + return + end + +c====================== The end of dtrsl =============================== + + + diff --git a/sav_itr.f90 b/sav_itr.f90 new file mode 100644 index 0000000..7e54dc2 --- /dev/null +++ b/sav_itr.f90 @@ -0,0 +1,159 @@ +subroutine sav_itr + + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Save the result on the coarse grid ! +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + + use set_knd + use drv_str + use obs_str + use grd_str + use eof_str + use ctl_str + use bmd_str + use rcfl + + implicit none + +! --- +! Save grid dimensions + + drv%im = grd%im + drv%jm = grd%jm +! Save eigenvalues + if (1.eq.0) then ! We do not know the reason of these lines + ALLOCATE ( drv%ro(drv%im,drv%jm,ros%neof)) ; drv%ro (:,:,:) = grd%ro (:,:,:) + ALLOCATE ( drv%ro_ad(drv%im,drv%jm,ros%neof)) ; drv%ro_ad(:,:,:) = grd%ro_ad(:,:,:) + ALLOCATE ( drv%msk(drv%im,drv%jm)) ; drv%msk (:,:) = grd%msr (:,:,1) + endif +! --- +! Deallocate everithing related to the old grid + +! Grid structure + DEALLOCATE ( grd%reg) + DEALLOCATE ( grd%msk) + DEALLOCATE ( grd%hgt) + DEALLOCATE ( grd%f) + if (drv%bphy.eq.1) then + DEALLOCATE ( grd%tem, grd%sal) + DEALLOCATE ( grd%uvl, grd%vvl) + DEALLOCATE ( grd%uvl_ad, grd%vvl_ad) + DEALLOCATE ( grd%b_x, grd%b_y) + DEALLOCATE ( grd%temb, grd%salb) + DEALLOCATE ( grd%tem_ad, grd%sal_ad) + DEALLOCATE ( grd%dns) + DEALLOCATE ( grd%eta) + DEALLOCATE ( grd%etab) + DEALLOCATE ( grd%sla) + DEALLOCATE ( grd%eta_ad) + endif + + DEALLOCATE ( grd%bx, grd%by) + DEALLOCATE ( grd%mdt ) + DEALLOCATE ( grd%lon, grd%lat, grd%dep) + DEALLOCATE ( grd%dx, grd%dy, grd%dz) + DEALLOCATE ( grd%dxdy) + DEALLOCATE ( grd%alx ) + DEALLOCATE ( grd%aly ) + DEALLOCATE ( grd%btx ) + DEALLOCATE ( grd%bty ) + DEALLOCATE ( grd%scx ) + DEALLOCATE ( grd%scy ) + DEALLOCATE ( grd%msr ) + DEALLOCATE ( grd%imx, grd%jmx) + DEALLOCATE ( grd%istp, grd%jstp) + DEALLOCATE ( grd%inx, grd%jnx) + DEALLOCATE ( grd%fct) + DEALLOCATE ( grd%aex) + DEALLOCATE ( grd%aey) + DEALLOCATE ( grd%bex) + DEALLOCATE ( grd%bey) + if(drv%biol.eq.1) then + DEALLOCATE ( grd%chl) + DEALLOCATE ( grd%chl_ad) + endif +! Observational vector + DEALLOCATE ( obs%inc, obs%amo, obs%res) + DEALLOCATE ( obs%err, obs%gra) +! Covariances structure + DEALLOCATE ( grd%ro) + DEALLOCATE ( grd%ro_ad) + DEALLOCATE ( ros%evc, ros%eva ) + DEALLOCATE ( ros%cor ) +! Control structure + DEALLOCATE( ctl%nbd, ctl%iwa) + DEALLOCATE( ctl%x_c, ctl%g_c) + DEALLOCATE( ctl%l_c, ctl%u_c) + DEALLOCATE( ctl%wa, ctl%sg, ctl%sgo, ctl%yg, ctl%ygo) + DEALLOCATE( ctl%ws, ctl%wy) + DEALLOCATE( ctl%sy, ctl%ss, ctl%yy) + DEALLOCATE( ctl%wt, ctl%wn, ctl%snd) + DEALLOCATE( ctl%z_c, ctl%r_c, ctl%d_c, ctl%t_c) + DEALLOCATE (SurfaceWaterpoints) + + + + DEALLOCATE ( a_rcx) + DEALLOCATE ( b_rcx) + DEALLOCATE ( c_rcx) + DEALLOCATE ( a_rcy) + DEALLOCATE ( b_rcy) + DEALLOCATE ( c_rcy) + DEALLOCATE ( alp_rcx) + DEALLOCATE ( bta_rcx) + DEALLOCATE ( alp_rcy) + DEALLOCATE ( bta_rcy) + DEALLOCATE (Dump_chl, Dump_vip, Dump_msk) + + write(*,*) ' DEALLOCATION DONE' +! Barotropic model + if(drv%bmd(drv%ktr) .eq. 1) then + DEALLOCATE ( bmd%itr) + DEALLOCATE ( bmd%mst, bmd%msu, bmd%msv) + DEALLOCATE ( bmd%hgt, bmd%hgu, bmd%hgv) + DEALLOCATE ( bmd%dxu, bmd%dxv) + DEALLOCATE ( bmd%dyu, bmd%dyv) + DEALLOCATE ( bmd%a1, bmd%a2, bmd%a3) + DEALLOCATE ( bmd%a4, bmd%a0, bmd%a00) + DEALLOCATE ( bmd%bx, bmd%by) + DEALLOCATE ( bmd%b_x, bmd%b_y) + DEALLOCATE ( bmd%dns) + DEALLOCATE ( bmd%bxby, bmd%rgh) + DEALLOCATE ( bmd%etb, bmd%ub, bmd%vb) + DEALLOCATE ( bmd%etn, bmd%un, bmd%vn) + DEALLOCATE ( bmd%eta, bmd%ua, bmd%va) + DEALLOCATE ( bmd%etm, bmd%um, bmd%vm) + DEALLOCATE ( bmd%div, bmd%cu, bmd%cv) + DEALLOCATE ( bmd%dux, bmd%duy) + DEALLOCATE ( bmd%dvx, bmd%dvy) + DEALLOCATE ( bmd%etx, bmd%ety) + endif + + +end subroutine sav_itr diff --git a/set_knd.f90 b/set_knd.f90 new file mode 100644 index 0000000..cfa20a9 --- /dev/null +++ b/set_knd.f90 @@ -0,0 +1,44 @@ +MODULE set_knd + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! The precision of reals and integers ! +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + +implicit none + +public + + INTEGER, PARAMETER :: & + r4 = SELECTED_REAL_KIND( 6, 37), & ! real*4 + r8 = SELECTED_REAL_KIND(12,307) ! real*8 + + INTEGER, PARAMETER :: & + i4 = SELECTED_INT_KIND(9) , & ! integer*4 + i8 = i4! ELECTED_INT_KIND(14) ! integer*8 + +END MODULE set_knd diff --git a/veof.f90 b/veof.f90 new file mode 100644 index 0000000..d322229 --- /dev/null +++ b/veof.f90 @@ -0,0 +1,160 @@ +subroutine veof +!anna +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Vertical transformation +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + + use set_knd + use drv_str + use grd_str + use eof_str + + implicit none + + INTEGER(i4) :: i, j, k, l,n, k1 + REAL(r8), DIMENSION ( grd%im, grd%jm) :: egm + + + if(drv%biol.eq.0 .or. drv%bphy.eq.1) then + grd%eta(:,: ) = 0.0 + grd%tem(:,:,:) = 0.0 + grd%sal(:,:,:) = 0.0 + endif + if(drv%biol.eq.1)then + do l=1,grd%nchl +!$OMP PARALLEL & +!$OMP PRIVATE(k) +!$OMP DO + do k=1,grd%km + grd%chl(:,:,k,l) = 0.0 + enddo +!$OMP END DO +!$OMP END PARALLEL + enddo + endif + +!cdir noconcur + do n=1,ros%neof + + egm(:,:) = 0.0 + +! egm + do l=1,n + do j=1,grd%jm + do i=1,grd%im +#ifdef opt_huge_memory +! egm(i,j) = egm(i,j) + ros%cor( i, j, l, n) * grd%ro(i,j,l) +#else +! egm(i,j) = egm(i,j) + ros%cor(grd%reg(i,j), l, n) * grd%ro(i,j,l) +#endif + enddo + enddo + enddo + + + do j=1,grd%jm + do i=1,grd%im +#ifdef opt_huge_memory + egm(i,j) = ros%eva( i, j, n) * grd%ro( i, j, n) +#else + egm(i,j) = ros%eva(grd%reg(i,j),n) * grd%ro( i, j, n) +#endif + enddo + enddo + + + if(drv%biol.eq.0 .or. drv%bphy.eq.1) then + +! Eta + if(drv%bmd(drv%ktr) .ne. 1)then + do j=1,grd%jm + do i=1,grd%im +#ifdef opt_huge_memory + grd%eta(i,j) = grd%eta(i,j) + ros%evc( i, j,1,n) * egm(i,j) +#else + grd%eta(i,j) = grd%eta(i,j) + ros%evc(grd%reg(i,j),1,n) * egm(i,j) +#endif + enddo + enddo + endif + + + + +! 3D variables + do k=1,grd%km + do j=1,grd%jm + do i=1,grd%im +#ifdef opt_huge_memory + grd%tem(i,j,k) = grd%tem(i,j,k) + ros%evc( i, j, k+1 , n) * egm(i,j) + grd%sal(i,j,k) = grd%sal(i,j,k) + ros%evc( i, j, k+grd%km+1, n) * egm(i,j) +#else + grd%tem(i,j,k) = grd%tem(i,j,k) + ros%evc(grd%reg(i,j), k+1 ,n) * egm(i,j) + grd%sal(i,j,k) = grd%sal(i,j,k) + ros%evc(grd%reg(i,j),k+grd%km+1,n) * egm(i,j) +#endif + enddo + enddo + enddo + + write(6,*) "this branch is not parallelized!!!" + stop + endif + + if(drv%biol.eq.1)then + +! 3D variables + if(drv%bphy.eq.1)then + k1 = 2*grd%km+1 + else + k1 = 0 + endif + do l=1,grd%nchl +!$OMP PARALLEL & +!$OMP PRIVATE(i,j,k,k1) +!$OMP DO + do k=1,grd%km ! OMP + k1 = k1 + 1 + do j=1,grd%jm + do i=1,grd%im +#ifdef opt_huge_memory + grd%chl(i,j,k,l) = grd%chl(i,j,k,l) + ros%evc( i, j, k1, n) * egm(i,j) +#else + grd%chl(i,j,k,l) = grd%chl(i,j,k,l) + ros%evc(grd%reg(i,j),k,n) * egm(i,j) +#endif + enddo + enddo + enddo +!$OMP END DO +!$OMP END PARALLEL + enddo + + endif + + enddo + +end subroutine veof diff --git a/veof_ad.f90 b/veof_ad.f90 new file mode 100644 index 0000000..7b95b3e --- /dev/null +++ b/veof_ad.f90 @@ -0,0 +1,143 @@ +subroutine veof_ad + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Vertical transformation (adjoint) ! +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + + use set_knd + use drv_str + use grd_str + use eof_str + + implicit none + + INTEGER(i4) :: i, j, k, l, n, k1 + REAL(r8), DIMENSION ( grd%im, grd%jm) :: egm + + grd%ro_ad(:,:,:) = 0.0 ! OMP + +!$OMP PARALLEL & +!$OMP PRIVATE(i,j,k,k1,n) & +!$OMP PRIVATE(egm) +!$OMP DO + do n=1,ros%neof + + egm(:,:) = 0.0 + + if(drv%biol.eq.0 .or. drv%bphy.eq.1) then + +! Eta + if(drv%bmd(drv%ktr) .ne. 1)then + do j=1,grd%jm + do i=1,grd%im +#ifdef opt_huge_memory + egm(i,j) = egm(i,j) + ros%evc( i, j, 1,n) * grd%eta_ad(i,j) +#else + egm(i,j) = egm(i,j) + ros%evc(grd%reg(i,j), 1,n) * grd%eta_ad(i,j) +#endif + enddo + enddo + endif + + + +! 3D variables + do k=1,grd%km + do j=1,grd%jm + do i=1,grd%im +#ifdef opt_huge_memory + egm(i,j) = egm(i,j) + ros%evc( i, j, k+1 ,n) * grd%tem_ad(i,j,k) + egm(i,j) = egm(i,j) + ros%evc( i, j, k+grd%km+1,n) * grd%sal_ad(i,j,k) +#else + egm(i,j) = egm(i,j) + ros%evc(grd%reg(i,j), k+1 ,n) * grd%tem_ad(i,j,k) + egm(i,j) = egm(i,j) + ros%evc(grd%reg(i,j), k+grd%km+1,n) * grd%sal_ad(i,j,k) +#endif + enddo + enddo + enddo + + endif + + + if(drv%biol.eq.1)then + +! 3D variables + if(drv%bphy.eq.1)then + k1 = 2*grd%km+1 + else + k1 = 0 + endif + do l=1,grd%nchl + do k=1,grd%km ! OMP + k1 = k1 + 1 + do j=1,grd%jm + do i=1,grd%im +#ifdef opt_huge_memory + egm(i,j) = egm(i,j) + ros%evc( i, j, k1,n) * grd%chl_ad(i,j,k,l) +#else + egm(i,j) = egm(i,j) + ros%evc(grd%reg(i,j), k,n) * grd%chl_ad(i,j,k,l) +#endif + enddo + enddo + enddo + enddo + + endif + + + do j=1,grd%jm + do i=1,grd%im +#ifdef opt_huge_memory + egm(i,j) = ros%eva( i, j, n) * egm(i,j) +#else + egm(i,j) = ros%eva(grd%reg(i,j),n) * egm(i,j) +#endif + enddo + enddo + +!cdir serial +! 3D variables +! do l=n,ros%neof + do j=1,grd%jm + do i=1,grd%im +#ifdef opt_huge_memory + grd%ro_ad(i,j,n) = grd%ro_ad(i,j,n) + egm(i,j) ! * ros%cor( i, j, n, l) +#else + grd%ro_ad(i,j,n) = grd%ro_ad(i,j,n) + egm(i,j) ! * ros%cor( grd%reg(i,j), n, l) +#endif + enddo + enddo +! enddo +!cdir end serial + + enddo +!$OMP END DO +!$OMP END PARALLEL + + +end subroutine veof_ad diff --git a/ver_hor.f90 b/ver_hor.f90 new file mode 100644 index 0000000..c4549ff --- /dev/null +++ b/ver_hor.f90 @@ -0,0 +1,336 @@ +subroutine ver_hor + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Apply horizontal filter ! +! ! +! Version 1: S.Dobricic 2006 ! +! Version 2: S.Dobricic 2007 ! +! Symmetric calculation in presence of coastal boundaries ! +! eta_ad, tem_ad, and sal_ad are here temporary arrays ! +! Version 3: A. Teruzzi 2013 ! +! Attenuation of correction near the cost where d<200m ! +!----------------------------------------------------------------------- + + + use set_knd + use grd_str + use eof_str + use cns_str + use drv_str + use obs_str + implicit none + + INTEGER(i4) :: i,j,k, ione, l + INTEGER :: jp,nestr + REAL(r8) :: chlapp(8),chlsum + + ione = 1 + +! --- +! Vertical EOFs + call veof +!return +!goto 103 !No Vh + +! --- +! Load temporary arrays + if(drv%mask(drv%ktr) .gt. 1) then + if(drv%biol.eq.0 .or. drv%bphy.eq.1)then + if(drv%bmd(drv%ktr) .ne. 1) & + grd%eta_ad(:,: ) = grd%eta(:,: ) + grd%tem_ad(:,:,:) = grd%tem(:,:,:) + grd%sal_ad(:,:,:) = grd%sal(:,:,:) + endif + if(drv%biol.eq.1) then + do l=1,grd%nchl +!$OMP PARALLEL & +!$OMP PRIVATE(k) +!$OMP DO + do k=1,grd%km + grd%chl_ad(:,:,k,l) = grd%chl(:,:,k,l) + enddo +!$OMP END DO +!$OMP END PARALLEL + enddo + endif + endif +! +! Attenuation of the correction near the cost and where d<200m + do l=1,grd%nchl + do j=2,grd%jm-1 + do i=2,grd%im-1 + if ((grd%msk(i,j,chl%kdp).eq.0).and. & + (grd%msk(i,j,1).eq.1)) then + do k=1,grd%km + if(grd%msk(i,j,k).eq.1) then + chlapp(1)=grd%chl(i+1,j, k,l) + chlapp(2)=grd%chl(i-1,j, k,l) + chlapp(3)=grd%chl(i, j+1,k,l) + chlapp(4)=grd%chl(i, j-1,k,l) + chlapp(5)=grd%chl(i+1,j+1,k,l) + chlapp(6)=grd%chl(i+1,j-1,k,l) + chlapp(7)=grd%chl(i-1,j+1,k,l) + chlapp(8)=grd%chl(i-1,j-1,k,l) + nestr=0 + chlsum=0. + do jp=1,8 + if ((chlapp(jp).ne.0).and.(chlapp(jp)/chlapp(jp).eq.1)) then + nestr=nestr+1; + chlsum=chlsum+chlapp(jp) + endif + enddo ! do on jp + if (nestr.ne.0) then + grd%chl(i,j,k,l)=.1*chlsum/nestr + endif + endif !if on k + enddo ! do on k + endif ! if on grd%chl(i,j,1,l) + enddo ! do on i + enddo ! do on j + enddo ! do on l +! --- +! x direction + if(drv%biol.eq.0 .or. drv%bphy.eq.1)then + if(drv%bmd(drv%ktr) .ne. 1) & + call rcfl_x( grd%im, grd%jm, ione, grd%imax, grd%aex, grd%bex, grd%eta, grd%inx, grd%imx) + call rcfl_x( grd%im, grd%jm, grd%km, grd%imax, grd%aex, grd%bex, grd%tem, grd%inx, grd%imx) + call rcfl_x( grd%im, grd%jm, grd%km, grd%imax, grd%aex, grd%bex, grd%sal, grd%inx, grd%imx) + endif + if(drv%biol.eq.1) then + call rcfl_x( grd%im, grd%jm, grd%km*grd%nchl, grd%imax, grd%aex, grd%bex, grd%chl, grd%inx, grd%imx) + endif +! --- +! Scale by the scaling factor + if(drv%biol.eq.0 .or. drv%bphy.eq.1)then + if(drv%bmd(drv%ktr) .ne. 1) & + grd%eta(:,:) = grd%eta(:,:) * grd%scx(:,:) + do k=1,grd%km + grd%tem(:,:,k) = grd%tem(:,:,k) * grd%scx(:,:) + grd%sal(:,:,k) = grd%sal(:,:,k) * grd%scx(:,:) + enddo + endif + + if(drv%biol.eq.1) then + do l=1,grd%nchl +!$OMP PARALLEL & +!$OMP PRIVATE(k) +!$OMP DO + do k=1,grd%km + grd%chl(:,:,k,l) = grd%chl(:,:,k,l) * grd%scx(:,:) + enddo +!$OMP END DO +!$OMP END PARALLEL + enddo + endif +! --- +! y direction + if(drv%biol.eq.0 .or. drv%bphy.eq.1)then + if(drv%bmd(drv%ktr) .ne. 1) & + call rcfl_y( grd%im, grd%jm, ione, grd%jmax, grd%aey, grd%bey, grd%eta, grd%jnx, grd%jmx) + call rcfl_y( grd%im, grd%jm, grd%km, grd%jmax, grd%aey, grd%bey, grd%tem, grd%jnx, grd%jmx) + call rcfl_y( grd%im, grd%jm, grd%km, grd%jmax, grd%aey, grd%bey, grd%sal, grd%jnx, grd%jmx) + endif + if(drv%biol.eq.1) then + call rcfl_y( grd%im, grd%jm, grd%km*grd%nchl, grd%jmax, grd%aey, grd%bey, grd%chl, grd%jnx, grd%jmx) + endif +! --- +! Scale by the scaling factor + if(drv%biol.eq.0 .or. drv%bphy.eq.1)then + if(drv%bmd(drv%ktr) .ne. 1) & + grd%eta(:,:) = grd%eta(:,:) * grd%scy(:,:) + do k=1,grd%km + grd%tem(:,:,k) = grd%tem(:,:,k) * grd%scy(:,:) + grd%sal(:,:,k) = grd%sal(:,:,k) * grd%scy(:,:) + enddo + endif + if(drv%biol.eq.1) then + do l=1,grd%nchl +!$OMP PARALLEL & +!$OMP PRIVATE(k) +!$OMP DO + do k=1,grd%km + grd%chl(:,:,k,l) = grd%chl(:,:,k,l) * grd%scy(:,:) + enddo +!$OMP END DO +!$OMP END PARALLEL + enddo + endif + +! --- +! Transpose calculation in the presense of coastal boundaries + if(drv%mask(drv%ktr) .gt. 1) then + +! --- +! Scale by the scaling factor + if(drv%biol.eq.0 .or. drv%bphy.eq.1)then + if(drv%bmd(drv%ktr) .ne. 1) & + grd%eta_ad(:,:) = grd%eta_ad(:,:) * grd%scy(:,:) + do k=1,grd%km + grd%tem_ad(:,:,k) = grd%tem_ad(:,:,k) * grd%scy(:,:) + grd%sal_ad(:,:,k) = grd%sal_ad(:,:,k) * grd%scy(:,:) + enddo + endif + if(drv%biol.eq.1) then + do l=1,grd%nchl +!$OMP PARALLEL & +!$OMP PRIVATE(k) +!$OMP DO + do k=1,grd%km + grd%chl_ad(:,:,k,l) = grd%chl_ad(:,:,k,l) * grd%scy(:,:) + enddo +!$OMP END DO +!$OMP END PARALLEL + enddo + endif +! --- +! y direction + if(drv%biol.eq.0 .or. drv%bphy.eq.1)then + if(drv%bmd(drv%ktr) .ne. 1) & + call rcfl_y_ad( grd%im, grd%jm, ione, grd%jmax, grd%aey, grd%bey, grd%eta_ad, grd%jnx, grd%jmx) + call rcfl_y_ad( grd%im, grd%jm, grd%km, grd%jmax, grd%aey, grd%bey, grd%tem_ad, grd%jnx, grd%jmx) + call rcfl_y_ad( grd%im, grd%jm, grd%km, grd%jmax, grd%aey, grd%bey, grd%sal_ad, grd%jnx, grd%jmx) + endif + if(drv%biol.eq.1) then + call rcfl_y_ad( grd%im, grd%jm, grd%km*grd%nchl, grd%jmax, grd%aey, grd%bey, grd%chl_ad, grd%jnx, grd%jmx) + endif +! --- +! Scale by the scaling factor + if(drv%biol.eq.0 .or. drv%bphy.eq.1)then + if(drv%bmd(drv%ktr) .ne. 1) & + grd%eta_ad(:,:) = grd%eta_ad(:,:) * grd%scx(:,:) + do k=1,grd%km + grd%tem_ad(:,:,k) = grd%tem_ad(:,:,k) * grd%scx(:,:) + grd%sal_ad(:,:,k) = grd%sal_ad(:,:,k) * grd%scx(:,:) + enddo + endif + if(drv%biol.eq.1) then + do l=1,grd%nchl +!$OMP PARALLEL & +!$OMP PRIVATE(k) +!$OMP DO + do k=1,grd%km + grd%chl_ad(:,:,k,l) = grd%chl_ad(:,:,k,l) * grd%scx(:,:) + enddo +!$OMP END DO +!$OMP END PARALLEL + enddo + endif +! --- +! x direction + if(drv%biol.eq.0 .or. drv%bphy.eq.1)then + if(drv%bmd(drv%ktr) .ne. 1) & + call rcfl_x_ad( grd%im, grd%jm, ione, grd%imax, grd%aex, grd%bex, grd%eta_ad, grd%inx, grd%imx) + call rcfl_x_ad( grd%im, grd%jm, grd%km, grd%imax, grd%aex, grd%bex, grd%tem_ad, grd%inx, grd%imx) + call rcfl_x_ad( grd%im, grd%jm, grd%km, grd%imax, grd%aex, grd%bex, grd%sal_ad, grd%inx, grd%imx) + endif + if(drv%biol.eq.1) then + call rcfl_x_ad( grd%im, grd%jm, grd%km*grd%nchl, grd%imax, grd%aex, grd%bex, grd%chl_ad, grd%inx, grd%imx) + endif + +! --- +! Average + if(drv%biol.eq.0 .or. drv%bphy.eq.1)then + if(drv%bmd(drv%ktr) .ne. 1) & + grd%eta(:,: ) = (grd%eta(:,: ) + grd%eta_ad(:,: ) ) * 0.5 + grd%tem(:,:,:) = (grd%tem(:,:,:) + grd%tem_ad(:,:,:) ) * 0.5 + grd%sal(:,:,:) = (grd%sal(:,:,:) + grd%sal_ad(:,:,:) ) * 0.5 + endif + if(drv%biol.eq.1) then + do l=1,grd%nchl +!$OMP PARALLEL & +!$OMP PRIVATE(k) +!$OMP DO + do k=1,grd%km + grd%chl(:,:,k,l) = (grd%chl(:,:,k,l) + grd%chl_ad(:,:,k,l) ) * 0.5 + enddo +!$OMP END DO +!$OMP END PARALLEL + enddo + endif + + endif + + +! --- +! Scale for boundaries + if(drv%biol.eq.0 .or. drv%bphy.eq.1)then + if(drv%bmd(drv%ktr) .ne. 1) & + grd%eta(:,:) = grd%eta(:,:) * grd%fct(:,:,1) + grd%tem(:,:,:) = grd%tem(:,:,:) * grd%fct(:,:,:) + grd%sal(:,:,:) = grd%sal(:,:,:) * grd%fct(:,:,:) + endif + if(drv%biol.eq.1) then + do l=1,grd%nchl +!$OMP PARALLEL & +!$OMP PRIVATE(k) +!$OMP DO + do k=1,grd%km + grd%chl(:,:,k,l) = grd%chl(:,:,k,l) * grd%fct(:,:,k) + enddo +!$OMP END DO +!$OMP END PARALLEL + enddo + endif + + +#ifdef __FISICA +! --- +! Bouyancy force + call get_byg + +! --- +! Barotropic model + if(drv%bmd(drv%ktr) .eq. 1) then + call bar_mod + endif + +! --- +! Barotropic model + call get_vel + +! --- +! Divergence damping + if(drv%dda(drv%ktr) .eq. 1) then + call div_dmp + endif + +#endif + +!103 continue +! Correction is zero out of mask (for correction near the coast) + if(drv%biol.eq.1) then + do k=1,grd%km + do j=1,grd%jm + do i=1,grd%im + if (grd%msk(i,j,k).eq.0) then + grd%chl(i,j,k,:) = 0. + endif + enddo !i + enddo !j + enddo !k + endif + + +end subroutine ver_hor diff --git a/ver_hor_ad.f90 b/ver_hor_ad.f90 new file mode 100644 index 0000000..82693a4 --- /dev/null +++ b/ver_hor_ad.f90 @@ -0,0 +1,363 @@ +subroutine ver_hor_ad + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Transformation from physical to control space ! +! ! +! Version 1: S.Dobricic 2006 ! +! Version 2: S.Dobricic 2007 ! +! Symmetric calculation in presence of coastal boundaries ! +! eta, tem, and sal are here temporary arrays ! +! Version 3: A.Teruzzi 2013 ! +! Smoothing of the solution at d<200m ! +!----------------------------------------------------------------------- + + + use set_knd + use grd_str + use eof_str + use cns_str + use drv_str + use obs_str + + implicit none + + INTEGER(i4) :: i,j,k, ione, l + INTEGER :: jp,nestr + REAL(r8) :: chlapp(8),chlsum + +! --- +! Correction is zero out of mask (for correction near the coast) + if(drv%biol.eq.1) then + do k=1,grd%km + do j=1,grd%jm + do i=1,grd%im + if (grd%msk(i,j,k).eq.0) then + grd%chl_ad(i,j,k,:) = 0. + endif + enddo !i + enddo !j + enddo !k + endif + + + +!goto 103 ! No Vh + ione = 1 + + +#ifdef __FISICA + +! --- +! Divergence damping + if(drv%dda(drv%ktr) .eq. 1) then + call div_dmp_ad + endif + +! --- +! Velocity + call get_vel_ad + +! --- +! Barotropic model + if(drv%bmd(drv%ktr) .eq. 1) then + call bar_mod_ad + endif + +! --- +! Bouyancy force + call get_byg_ad + +#endif + +! --- +! Scale for boundaries + if(drv%biol.eq.0 .or. drv%bphy.eq.1)then + if(drv%bmd(drv%ktr) .ne. 1) & + grd%eta_ad(:,:) = grd%eta_ad(:,:) * grd%fct(:,:,1) + grd%tem_ad(:,:,:) = grd%tem_ad(:,:,:) * grd%fct(:,:,:) + grd%sal_ad(:,:,:) = grd%sal_ad(:,:,:) * grd%fct(:,:,:) + endif + + + if(drv%biol.eq.1) then + do l=1,grd%nchl +!$OMP PARALLEL & +!$OMP PRIVATE(k) +!$OMP DO + do k=1,grd%km + grd%chl_ad(:,:,k,l) = grd%chl_ad(:,:,k,l) * grd%fct(:,:,k) + enddo +!$OMP END DO +!$OMP END PARALLEL + enddo + endif + + + if(drv%mask(drv%ktr) .gt. 1) then + +! --- +! Load temporary arrays + if(drv%biol.eq.0 .or. drv%bphy.eq.1)then + if(drv%bmd(drv%ktr) .ne. 1) & + grd%eta(:,: ) = grd%eta_ad(:,: ) + grd%tem(:,:,:) = grd%tem_ad(:,:,:) + grd%sal(:,:,:) = grd%sal_ad(:,:,:) + endif + if(drv%biol.eq.1) then + do l=1,grd%nchl +!$OMP PARALLEL & +!$OMP PRIVATE(k) +!$OMP DO + do k=1,grd%km + grd%chl(:,:,k,l) = grd%chl_ad(:,:,k,l) + enddo +!$OMP END DO +!$OMP END PARALLEL + enddo + endif + +! --- +! x direction + if(drv%biol.eq.0 .or. drv%bphy.eq.1)then + if(drv%bmd(drv%ktr) .ne. 1) & + call rcfl_x( grd%im, grd%jm, ione, grd%imax, grd%aex, grd%bex, grd%eta, grd%inx, grd%imx) + call rcfl_x( grd%im, grd%jm, grd%km, grd%imax, grd%aex, grd%bex, grd%tem, grd%inx, grd%imx) + call rcfl_x( grd%im, grd%jm, grd%km, grd%imax, grd%aex, grd%bex, grd%sal, grd%inx, grd%imx) + endif + if(drv%biol.eq.1) then + call rcfl_x( grd%im, grd%jm, grd%km*grd%nchl, grd%imax, grd%aex, grd%bex, grd%chl, grd%inx, grd%imx) + endif +! --- +! Scale by the scaling factor + if(drv%biol.eq.0 .or. drv%bphy.eq.1)then + if(drv%bmd(drv%ktr) .ne. 1) & + grd%eta(:,:) = grd%eta(:,:) * grd%scx(:,:) + do k=1,grd%km + grd%tem(:,:,k) = grd%tem(:,:,k) * grd%scx(:,:) + grd%sal(:,:,k) = grd%sal(:,:,k) * grd%scx(:,:) + enddo + endif + if(drv%biol.eq.1) then + do l=1,grd%nchl +!$OMP PARALLEL & +!$OMP PRIVATE(k) +!$OMP DO + do k=1,grd%km + grd%chl(:,:,k,l) = grd%chl(:,:,k,l) * grd%scx(:,:) + enddo +!$OMP END DO +!$OMP END PARALLEL + enddo + endif +! --- +! y direction + if(drv%biol.eq.0 .or. drv%bphy.eq.1)then + if(drv%bmd(drv%ktr) .ne. 1) & + call rcfl_y( grd%im, grd%jm, ione, grd%jmax, grd%aey, grd%bey, grd%eta, grd%jnx, grd%jmx) + call rcfl_y( grd%im, grd%jm, grd%km, grd%jmax, grd%aey, grd%bey, grd%tem, grd%jnx, grd%jmx) + call rcfl_y( grd%im, grd%jm, grd%km, grd%jmax, grd%aey, grd%bey, grd%sal, grd%jnx, grd%jmx) + endif + if(drv%biol.eq.1) then + call rcfl_y( grd%im, grd%jm, grd%km*grd%nchl, grd%jmax, grd%aey, grd%bey, grd%chl, grd%jnx, grd%jmx) + endif +! --- +! Scale by the scaling factor + if(drv%biol.eq.0 .or. drv%bphy.eq.1)then + if(drv%bmd(drv%ktr) .ne. 1) & + grd%eta(:,:) = grd%eta(:,:) * grd%scy(:,:) + do k=1,grd%km + grd%tem(:,:,k) = grd%tem(:,:,k) * grd%scy(:,:) + grd%sal(:,:,k) = grd%sal(:,:,k) * grd%scy(:,:) + enddo + endif + if(drv%biol.eq.1) then + do l=1,grd%nchl +!$OMP PARALLEL & +!$OMP PRIVATE(k) +!$OMP DO + do k=1,grd%km + grd%chl(:,:,k,l) = grd%chl(:,:,k,l) * grd%scy(:,:) + enddo +!$OMP END DO +!$OMP END PARALLEL + enddo + endif + + endif + +! --- +! Scale by the scaling factor + if(drv%biol.eq.0 .or. drv%bphy.eq.1)then + if(drv%bmd(drv%ktr) .ne. 1) & + grd%eta_ad(:,:) = grd%eta_ad(:,:) * grd%scy(:,:) + do k=1,grd%km + grd%tem_ad(:,:,k) = grd%tem_ad(:,:,k) * grd%scy(:,:) + grd%sal_ad(:,:,k) = grd%sal_ad(:,:,k) * grd%scy(:,:) + enddo + endif + if(drv%biol.eq.1) then + do l=1,grd%nchl +!$OMP PARALLEL & +!$OMP PRIVATE(k) +!$OMP DO + do k=1,grd%km + grd%chl_ad(:,:,k,l) = grd%chl_ad(:,:,k,l) * grd%scy(:,:) + enddo +!$OMP END DO +!$OMP END PARALLEL + enddo + endif + +! --- +! y direction + if(drv%biol.eq.0 .or. drv%bphy.eq.1)then + if(drv%bmd(drv%ktr) .ne. 1) & + call rcfl_y_ad( grd%im, grd%jm, ione, grd%jmax, grd%aey, grd%bey, grd%eta_ad, grd%jnx, grd%jmx) + call rcfl_y_ad( grd%im, grd%jm, grd%km, grd%jmax, grd%aey, grd%bey, grd%tem_ad, grd%jnx, grd%jmx) + call rcfl_y_ad( grd%im, grd%jm, grd%km, grd%jmax, grd%aey, grd%bey, grd%sal_ad, grd%jnx, grd%jmx) + endif + if(drv%biol.eq.1) then + call rcfl_y_ad( grd%im, grd%jm, grd%km*grd%nchl, grd%jmax, grd%aey, grd%bey, grd%chl_ad, grd%jnx, grd%jmx) +! write(*,*) 'AFTER rcfl_y_ad', grd%chl_ad(71,12,1,1) + endif + +! --- +! Scale by the scaling factor + if(drv%biol.eq.0 .or. drv%bphy.eq.1)then + if(drv%bmd(drv%ktr) .ne. 1) & + grd%eta_ad(:,:) = grd%eta_ad(:,:) * grd%scx(:,:) + do k=1,grd%km + grd%tem_ad(:,:,k) = grd%tem_ad(:,:,k) * grd%scx(:,:) + grd%sal_ad(:,:,k) = grd%sal_ad(:,:,k) * grd%scx(:,:) + enddo + endif + if(drv%biol.eq.1) then + do l=1,grd%nchl +!$OMP PARALLEL & +!$OMP PRIVATE(k) +!$OMP DO + do k=1,grd%km + grd%chl_ad(:,:,k,l) = grd%chl_ad(:,:,k,l) * grd%scx(:,:) + enddo +!$OMP END DO +!$OMP END PARALLEL + enddo + endif + +! --- +! x direction + if(drv%biol.eq.0 .or. drv%bphy.eq.1)then + if(drv%bmd(drv%ktr) .ne. 1) & + call rcfl_x_ad( grd%im, grd%jm, ione, grd%imax, grd%aex, grd%bex, grd%eta_ad, grd%inx, grd%imx) + call rcfl_x_ad( grd%im, grd%jm, grd%km, grd%imax, grd%aex, grd%bex, grd%tem_ad, grd%inx, grd%imx) + call rcfl_x_ad( grd%im, grd%jm, grd%km, grd%imax, grd%aex, grd%bex, grd%sal_ad, grd%inx, grd%imx) + endif + if(drv%biol.eq.1) then + call rcfl_x_ad( grd%im, grd%jm, grd%km*grd%nchl, grd%imax, grd%aex, grd%bex, grd%chl_ad, grd%inx, grd%imx) + endif + + +! --- +! Average + if(drv%mask(drv%ktr) .gt. 1) then + if(drv%biol.eq.0 .or. drv%bphy.eq.1)then + if(drv%bmd(drv%ktr) .ne. 1) & + grd%eta_ad(:,: ) = (grd%eta_ad(:,: ) + grd%eta(:,: ) ) * 0.5 + grd%tem_ad(:,:,:) = (grd%tem_ad(:,:,:) + grd%tem(:,:,:) ) * 0.5 + grd%sal_ad(:,:,:) = (grd%sal_ad(:,:,:) + grd%sal(:,:,:) ) * 0.5 + + endif + if(drv%biol.eq.1) then + do l=1,grd%nchl +!$OMP PARALLEL & +!$OMP PRIVATE(k) +!$OMP DO + do k=1,grd%km + grd%chl_ad(:,:,k,l) = (grd%chl_ad(:,:,k,l) + grd%chl(:,:,k,l) ) * 0.5 + enddo +!$OMP END DO +!$OMP END PARALLEL + enddo + endif + endif + +!anna sreduction of correction d<200m + do l=1,grd%nchl + do j=2,grd%jm-1 ! OMP + do i=2,grd%im-1 + if ((grd%msk(i,j,chl%kdp).eq.0).and. & + (grd%msk(i,j,1).eq.1)) then + do k=1,grd%km + if(grd%msk(i,j,k).eq.1) then + chlapp(1)=grd%chl(i+1,j, k,l) + chlapp(2)=grd%chl(i-1,j, k,l) + chlapp(3)=grd%chl(i, j+1,k,l) + chlapp(4)=grd%chl(i, j-1,k,l) + chlapp(5)=grd%chl(i+1,j+1,k,l) + chlapp(6)=grd%chl(i+1,j-1,k,l) + chlapp(7)=grd%chl(i-1,j+1,k,l) + chlapp(8)=grd%chl(i-1,j-1,k,l) + nestr=0 + do jp=1,8 + if ((chlapp(jp).ne.0).and.(chlapp(jp)/chlapp(jp).eq.1)) then + nestr=nestr+1; + endif + enddo ! do on jp + if (nestr.ne.0) then + grd%chl_ad(i+1,j, k,l)=grd%chl_ad(i+1,j, k,l)+ & + .1*grd%chl_ad(i,j,k,l)/nestr + grd%chl_ad(i-1,j, k,l)=grd%chl_ad(i-1,j, k,l)+ & + .1*grd%chl_ad(i,j,k,l)/nestr + grd%chl_ad(i, j+1,k,l)=grd%chl_ad(i ,j+1,k,l)+ & + .1*grd%chl_ad(i,j,k,l)/nestr + grd%chl_ad(i, j-1,k,l)=grd%chl_ad(i ,j-1,k,l)+ & + .1*grd%chl_ad(i,j,k,l)/nestr + grd%chl_ad(i+1,j+1,k,l)=grd%chl_ad(i+1,j+1,k,l)+ & + .1*grd%chl_ad(i,j,k,l)/nestr + grd%chl_ad(i+1,j-1,k,l)=grd%chl_ad(i+1,j-1,k,l)+ & + .1*grd%chl_ad(i,j,k,l)/nestr + grd%chl_ad(i-1,j+1,k,l)=grd%chl_ad(i-1,j+1,k,l)+ & + .1*grd%chl_ad(i,j,k,l)/nestr + grd%chl_ad(i-1,j-1,k,l)=grd%chl_ad(i-1,j-1,k,l)+ & + .1*grd%chl_ad(i,j,k,l)/nestr + grd%chl_ad(i,j,k,l)=0. + endif + endif !if on k + enddo ! do on k + endif ! if on grd%chl(i,j,1,l) + enddo ! do on i + enddo ! do on j + enddo ! do on l + + + + +!103 continue +! --- +! Vertical EOFs + call veof_ad + + +end subroutine ver_hor_ad diff --git a/wrt_dia.f90 b/wrt_dia.f90 new file mode 100644 index 0000000..38587bc --- /dev/null +++ b/wrt_dia.f90 @@ -0,0 +1,229 @@ +subroutine wrt_dia + +!--------------------------------------------------------------------------- +! ! +! Copyright 2006 Srdjan Dobricic, CMCC, Bologna ! +! ! +! This file is part of OceanVar. ! +! ! +! OceanVar is free software: you can redistribute it and/or modify. ! +! it under the terms of the GNU General Public License as published by ! +! the Free Software Foundation, either version 3 of the License, or ! +! (at your option) any later version. ! +! ! +! OceanVar is distributed in the hope that it will be useful, ! +! but WITHOUT ANY WARRANTY; without even the implied warranty of ! +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! +! GNU General Public License for more details. ! +! ! +! You should have received a copy of the GNU General Public License ! +! along with OceanVar. If not, see . ! +! ! +!--------------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ! +! Write outputs and diagnostics ! +! ! +! Version 1: S.Dobricic 2006 ! +!----------------------------------------------------------------------- + + + use set_knd + use drv_str + use obs_str + use grd_str + use eof_str + use ctl_str + use bmd_str + use netcdf + use filenames + implicit none + + INTEGER(i4) :: l,i,j,k +! REAL :: Dump_chl(grd%im,grd%jm,grd%km) +! REAL :: Dump_vip(grd%im,grd%jm,ros%neof) + CHARACTER :: fgrd + integer status + integer :: ncid,xid,yid,depid,idchl + integer :: idvip,idmsk,eofid + + + +! --- +! Innovations + +#ifdef __FISICA + REAL :: x2(grd%im,grd%jm) + x2(:,:) = grd%eta(:,:) + write(101) x2 + do k=1,grd%km + x2(:,:) = grd%tem(:,:,k) + write(101) x2 + enddo + do k=1,grd%km + x2(:,:) = grd%sal(:,:,k) + write(101) x2 + enddo + do k=1,grd%km + x2(:,:) = grd%uvl(:,:,k) + write(101) x2 + enddo + do k=1,grd%km + x2(:,:) = grd%vvl(:,:,k) + write(101) x2 + enddo +#endif + + write(drv%dia,*) 'writes to corrections.dat !!!!!!!!!!!!!!!!!!!!!!!!!' + + write(fgrd,'(i1)')drv%ktr + + if(drv%biol.eq.1) then + do l=1,grd%nchl + do k=1,grd%km + do j=1,grd%jm + do i=1,grd%im + Dump_chl(i,j,k) = REAL(grd%chl(i,j,k,l), 4 ) + enddo + enddo + enddo + enddo + + endif + do j=1,grd%jm + do i=1,grd%im + Dump_msk(i,j) = real(grd%msk(i,j,1),4); + enddo + enddo + + +status = nf90_create(trim(CORR_FILE), NF90_CLOBBER, ncid) +status = nf90_def_dim(ncid,'depth' ,grd%km, depid) +status = nf90_def_dim(ncid,'latitude' ,grd%jm ,yid) +status = nf90_def_dim(ncid,'longitude',grd%im ,xid) + +status = nf90_def_var(ncid,'chl', nf90_float, (/xid,yid,depid/), idchl ) +status = nf90_enddef(ncid) + +status = nf90_put_var(ncid,idchl,Dump_chl) +status = nf90_sync(ncid) +status = nf90_close(ncid) + + +do k=1, ros%neof +do j=1, grd%jm +do i=1, grd%im + Dump_vip(i,j,k) = real(grd%ro(i,j,k), 4) +enddo +enddo +enddo + +status = nf90_create(trim(EIV_FILE), NF90_CLOBBER, ncid) ! Eigenvalues +status = nf90_def_dim(ncid,'neof' ,ros%neof ,eofid) +status = nf90_def_dim(ncid,'latitude' ,grd%jm ,yid) +status = nf90_def_dim(ncid,'longitude',grd%im ,xid) +status = nf90_def_var(ncid,'msk' , nf90_float, (/xid,yid/) , idmsk ) +status = nf90_def_var(ncid,'vip' , nf90_float, (/xid,yid,eofid/), idvip ) +status = nf90_enddef(ncid) +status = nf90_put_var(ncid,idmsk, Dump_msk ) +status = nf90_put_var(ncid,idvip, Dump_vip ) +status = nf90_sync(ncid) +status = nf90_close(ncid) + + +! --- +! Observations + +! open(215,file=drv%flag//drv%date//'obs_'//fgrd//'.dat',form='unformatted') + open(215,file=trim(OBS_FILE),form='unformatted') + + write(215) sla%no + if(sla%no.gt.0) write(215) & + sla%ino(1:sla%no), sla%flg(1:sla%no) & + ,sla%lon(1:sla%no), sla%lat(1:sla%no), sla%tim(1:sla%no)& + ,sla%val(1:sla%no), sla%bac(1:sla%no) & + ,sla%err(1:sla%no), sla%res(1:sla%no) & + ,sla%bia(1:sla%no), sla%inc(1:sla%no) & + ,sla%b_a(1:sla%no) & + ,sla%dpt(1:sla%no) + write(215) arg%no + if(arg%no.ne.0) write (215) & + arg%ino(1:arg%no), arg%flg(1:arg%no), arg%par(1:arg%no) & + ,arg%lon(1:arg%no), arg%lat(1:arg%no) & + ,arg%dpt(1:arg%no), arg%tim(1:arg%no) & + ,arg%val(1:arg%no), arg%bac(1:arg%no) & + ,arg%err(1:arg%no), arg%res(1:arg%no) & + ,arg%bia(1:arg%no), arg%inc(1:arg%no) & + ,arg%b_a(1:arg%no) + write(215) xbt%no + if(xbt%no.ne.0) write (215) & + xbt%ino(1:xbt%no), xbt%flg(1:xbt%no), xbt%par(1:xbt%no) & + ,xbt%lon(1:xbt%no), xbt%lat(1:xbt%no) & + ,xbt%dpt(1:xbt%no), xbt%tim(1:xbt%no) & + ,xbt%val(1:xbt%no), xbt%bac(1:xbt%no) & + ,xbt%err(1:xbt%no), xbt%res(1:xbt%no) & + ,xbt%bia(1:xbt%no), xbt%inc(1:xbt%no) & + ,xbt%b_a(1:xbt%no) + write(215) gld%no + if(gld%no.ne.0) write (215) & + gld%ino(1:gld%no), gld%flg(1:gld%no), gld%par(1:gld%no) & + ,gld%lon(1:gld%no), gld%lat(1:gld%no) & + ,gld%dpt(1:gld%no), gld%tim(1:gld%no) & + ,gld%val(1:gld%no), gld%bac(1:gld%no) & + ,gld%err(1:gld%no), gld%res(1:gld%no) & + ,gld%bia(1:gld%no), gld%inc(1:gld%no) & + ,gld%b_a(1:gld%no) + write(215) tra%no + if(tra%no.ne.0) write (215) & + tra%dpt & + ,tra%ino(1:tra%no), tra%flg(1:tra%no) & + ,tra%loi(1:tra%no), tra%lai(1:tra%no) & + ,tra%lof(1:tra%no), tra%laf(1:tra%no) & + ,tra%lob(tra%nt+1,1:tra%no), tra%lab(tra%nt+1,1:tra%no) & + ,tra%rex(1:tra%no), tra%inx(1:tra%no) & + ,tra%rey(1:tra%no), tra%iny(1:tra%no) & + ,tra%loa(1:tra%no), tra%laa(1:tra%no) & + ,tra%erx(1:tra%no), tra%ery(1:tra%no) + write(215) trd%no + if(trd%no.ne.0) write (215) & + trd%dpt & + ,trd%ino(1:trd%no), trd%flg(1:trd%no) & + ,trd%loi(1:trd%no), trd%lai(1:trd%no) & + ,trd%lof(1:trd%no), trd%laf(1:trd%no) & + ,trd%lob(trd%nt+1,1:trd%no), trd%lab(trd%nt+1,1:trd%no) & + ,trd%rex(1:trd%no), trd%inx(1:trd%no) & + ,trd%rey(1:trd%no), trd%iny(1:trd%no) & + ,trd%loa(1:trd%no), trd%laa(1:trd%no) + write(215) vdr%no + if(vdr%no.ne.0) write (215) & + vdr%ino(1:vdr%no), vdr%flg(1:vdr%no), vdr%par(1:vdr%no) & + ,vdr%lon(1:vdr%no), vdr%lat(1:vdr%no) & + ,vdr%dpt(1:vdr%no), vdr%tim(1:vdr%no) & + ,vdr%tms(1:vdr%no), vdr%tme(1:vdr%no) & + ,vdr%val(1:vdr%no), vdr%bac(1:vdr%no) & + ,vdr%err(1:vdr%no), vdr%res(1:vdr%no) & + ,vdr%bia(1:vdr%no), vdr%inc(1:vdr%no) & + ,vdr%b_a(1:vdr%no) + write(215) gvl%no + if(gvl%no.ne.0) write (215) & + gvl%ino(1:gvl%no), gvl%flg(1:gvl%no), gvl%par(1:gvl%no) & + ,gvl%lon(1:gvl%no), gvl%lat(1:gvl%no) & + ,gvl%dpt(1:gvl%no), gvl%tim(1:gvl%no) & + ,gvl%tms(1:gvl%no), gvl%tme(1:gvl%no) & + ,gvl%val(1:gvl%no), gvl%bac(1:gvl%no) & + ,gvl%err(1:gvl%no), gvl%res(1:gvl%no) & + ,gvl%bia(1:gvl%no), gvl%inc(1:gvl%no) & + ,gvl%b_a(1:gvl%no) + write(215) chl%no +#ifdef __FISICA + if(chl%no.ne.0) write (215) & + gvl%flg(1:gvl%no) & + ,gvl%dpt(1:gvl%no) & + ,gvl%err(1:gvl%no), gvl%res(1:gvl%no) & + ,gvl%inc(1:gvl%no) +#endif + close (215) + write(*,*)'nchl ',chl%no + +end subroutine wrt_dia