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