diff --git a/Makefile b/Makefile
index b9dc20d..f62c26d 100644
--- a/Makefile
+++ b/Makefile
@@ -6,6 +6,7 @@ SHELL = /bin/sh
############################################################################
#
# Copyright 2006 Srdjan Dobricic, CMCC, Bologna
+# Copyright 2025 Jacopo Nespolo, Matteo Poggi, eXact lab S.r.l, Trieste
#
# This file is part of OceanVar.
#
@@ -24,19 +25,6 @@ SHELL = /bin/sh
#
############################################################################
-include compiler.inc
-
-ifndef NETCDF_INC
- export NETCDF_INC=/usr/include
-endif
-
-ifndef NETCDF_LIB
- export NETCDF_LIB=/usr/lib
-endif
-$(info $$NETCDF_INC = ${NETCDF_INC})
-$(info $$NETCDF_LIB = ${NETCDF_LIB})
-$(info $$LIBNCMEDLEV = ${LIBNCMEDLEV})
-
EXEC = var_3d
LIB = libvar_3d.a
@@ -49,7 +37,7 @@ KNDSTR = \
set_knd.o
OBJSTR = \
filename_mod.o\
- da_params.o\
+ da_params.o\
drv_str.o\
cns_str.o\
obs_str.o\
@@ -100,11 +88,15 @@ PHYSOBS = \
OBJS = \
def_nml.o\
+ def_nml_multi.o\
def_grd.o\
sav_itr.o\
- rdeofs.o\
- rdrcorr.o\
- mean_rdr.o\
+ rdeofs_chl.o\
+ rdeofs_n3n.o\
+ rdeofs_o2o.o\
+ rdeofs_multi.o\
+ rdrcorr.o\
+ mean_rdr.o\
netcdf_err.o\
get_obs.o\
get_obs_arg.o\
@@ -113,18 +105,23 @@ OBJS = \
obs_vec.o\
ini_cfn.o\
cnv_ctv.o\
- ver_hor.o\
+ ver_hor_chl.o\
+ ver_hor_nut.o\
rcfl_x.o\
rcfl_y.o\
- veof.o\
+ veof_chl.o\
+ veof_nut.o\
obsop.o\
obs_arg.o\
resid.o\
res_inc.o\
obsop_ad.o\
obs_arg_ad.o\
- veof_ad.o\
- ver_hor_ad.o\
+ veof_chl_ad.o\
+ veof_nut_ad.o\
+ veof_multiv_ad.o\
+ ver_hor_chl_ad.o\
+ ver_hor_nut_ad.o\
rcfl_x_ad.o\
rcfl_y_ad.o\
rcfl_y_ad_init.o\
@@ -137,8 +134,17 @@ OBJS = \
readAnisotropy.o\
bio_mod.o\
bio_mod_ad.o\
- readBioStat.o\
- wrt_bio_stat.o\
+ readChlStat.o\
+ readNutStat.o\
+ readNutCov.o\
+ readChlNutCov.o\
+ wrt_chl_stat.o\
+ wrt_upd_nut.o\
+ wrt_nut_stat.o\
+ wrt_o2o_stat.o\
+ cp_chl_stat.o\
+ cp_nut_stat.o\
+ cp_o2o_stat.o\
costf.o\
obs_sat.o\
bio_conv.o\
@@ -147,15 +153,41 @@ OBJS = \
readGrid.o\
def_cov.o\
tao_minimizer.o\
- oceanvar.o
+ oceanvar.o
MAINEXE = main.o
+# needed libraries
+depends = petsc netcdf netcdf-fortran pnetcdf
+
+# NOTE: It may happen that pkg-config returns a spurious `-I`. We pass the
+# string through sed to sanitise.
+INCLUDE_FLAGS ?= \
+ $(shell pkg-config --cflags --keep-system-cflags $(depends) | sed -E 's/-I(\s+|$$)//g')
+
+# set rpath in the binary, required in order to find the correct libs at runtime.
+# Env modules nowadays do not pollute the env with LD_LIBRARY_PATH, for good reason.
+LDFLAGS ?= \
+ $(shell pkg-config --libs $(depends)) \
+ -Wl,-rpath -Wl,$(shell pkg-config --libs-only-L $(depends) |sed 's/-L//' |sed 's/-L/:/g' |sed 's/ //g')
+
+FFLAGS ?= -O2 -ffree-line-length-none -c
+FC ?= mpif90
+LD ?= mpif90
+
+$(info $$INCLUDE_FLAGS = ${INCLUDE_FLAGS})
+$(info $$FFLAGS = ${FFLAGS})
+$(info $$LDFLAGS = ${LDFLAGS})
+$(info $$FC = ${FC})
+$(info $$LD = ${LD})
+
.SUFFIXES: .f90
+.PHONY:all
all: $(EXEC) $(LIB)
@echo $(EXEC) is compiled
+.PHONY:install
install: $(EXEC)
cp -p $(EXEC) $(INSTDIR)
@@ -165,31 +197,18 @@ $(EXEC) : $(LIBDEP) $(KNDSTR) $(OBJSTR) $(OBJS) $(MAINEXE)
$(LIB) : $(KNDSTR) $(OBJSTR) $(OBJS)
ar -r $(LIB) $(KNDSTR) $(OBJSTR) $(OBJS)
-tao_minimizer.o: tao_minimizer.f90
- $(CPP) -I$(PETSC_INC) $*.f90 > cpp.$*.f90 ; $(F90) -I$(PETSC_INC) $(FFLAGS) cpp.$*.f90 ; $(MV) cpp.$*.o $*.o
-
-mpi_utils.o: mpi_utils.f90
- $(CPP) -I$(PETSC_INC) $*.f90 > cpp.$*.f90 ; $(F90) -I$(PETSC_INC) $(FFLAGS) cpp.$*.f90 ; $(MV) cpp.$*.o $*.o
-
.DEFAULTS:
.f90.o :
- $(CPP) $*.f90 > cpp.$*.f90 ; $(F90) $(FFLAGS) cpp.$*.f90 ; $(MV) cpp.$*.o $*.o
-
-.f.o :
- $(CPP) $*.f > cpp.$*.f ; $(F77) $(FFLAGS) cpp.$*.f ; $(MV) cpp.$*.o $*.o
-
-libf_exit.a :
- cd $(LIBFEXIT) && $(MAKE)
+ $(FC) -cpp $(INCLUDE_FLAGS) $(FFLAGS) -o $@ $*.f90
-libnc-medlevel.a :
- cd $(LIBNCMEDLEV) && $(MAKE)
+libnc-medlevel.a : nc-med-level-lib.o
+ $(AR) cr $@ $<
+.PHONY:clean
clean:
- $(RM) *.o *.mod cpp.* *.L
- cd $(LIBNCMEDLEV) && $(MAKE) erase
- cd ..
+ $(RM) *.o *.mod cpp.* *.L *.a
+ $(RM) libnc-medlevel/*.a libnc-medlevel/*.o
+.PHONY:erease
erase:
$(RM) *.o *.mod cpp.* *.L $(EXEC)
- cd $(LIBNCMEDLEV) && $(MAKE) erase
- cd ..
diff --git a/bio_conv.f90 b/bio_conv.f90
index cffb5fb..4f59adf 100644
--- a/bio_conv.f90
+++ b/bio_conv.f90
@@ -29,16 +29,22 @@ subroutine bio_conv
!-----------------------------------------------------------------------
use grd_str
+ use eof_str
use bio_str
+ use drv_str
implicit none
- INTEGER(i4) :: i, j, k, l
+ INTEGER(i4) :: i, j, k, l, my_km
grd%chl(:,:,:) = 0.0
+ my_km = grd%km
+ if(drv%multiv.eq.1) &
+ my_km = ros%kmchl
+
do l = 1,bio%nphy
- do k = 1,grd%km
+ do k = 1,my_km
do j = 1,grd%jm
do i = 1,grd%im
grd%chl(i,j,k) = grd%chl(i,j,k) + bio%phy(i,j,k,l,1)
diff --git a/bio_conv_ad.f90 b/bio_conv_ad.f90
index 4378c9e..6d2582e 100644
--- a/bio_conv_ad.f90
+++ b/bio_conv_ad.f90
@@ -29,16 +29,22 @@ subroutine bio_conv_ad
!-----------------------------------------------------------------------
use grd_str
+ use eof_str
use bio_str
+ use drv_str
implicit none
- INTEGER(i4) :: i, j, k, l
+ INTEGER(i4) :: i, j, k, l, my_km
bio%phy_ad(:,:,:,:,:) = 0.0
+ my_km = grd%km
+ if(drv%multiv .eq. 1) &
+ my_km = ros%kmchl
+
do l = 1,bio%nphy
- do k = 1,grd%km
+ do k = 1,my_km
do j = 1,grd%jm
do i = 1,grd%im
bio%phy_ad(i,j,k,l,1) = bio%phy_ad(i,j,k,l,1) + grd%chl_ad(i,j,k)
diff --git a/bio_mod.f90 b/bio_mod.f90
index 7d10468..95b3f48 100644
--- a/bio_mod.f90
+++ b/bio_mod.f90
@@ -31,16 +31,21 @@ subroutine bio_mod
use grd_str
use bio_str
use eof_str
+ use drv_str
IMPLICIT NONE
- INTEGER(i4) :: m, l, k,j ,i
+ INTEGER(i4) :: m, l, k,j ,i, my_km
bio%phy(:,:,:,:,:) = 0.0
+ my_km = grd%km
+ if(drv%multiv .eq. 1) &
+ my_km = ros%kmchl
+
do m=1,bio%ncmp
do l=1,bio%nphy
- do k=1,grd%km
+ do k=1,my_km
do j=1,grd%jm
do i=1,grd%im
bio%phy(i,j,k,l,m)=bio%cquot(i,j,k,l,m)*bio%pquot(i,j,k,l)*grd%chl(i,j,k)
diff --git a/bio_mod_ad.f90 b/bio_mod_ad.f90
index 1ab9378..d714ae0 100644
--- a/bio_mod_ad.f90
+++ b/bio_mod_ad.f90
@@ -31,16 +31,21 @@ subroutine bio_mod_ad
use grd_str
use bio_str
use eof_str
+ use drv_str
IMPLICIT NONE
- INTEGER(i4) :: m, l, k, j, i
+ INTEGER(i4) :: m, l, k, j, i, my_km
grd%chl_ad(:,:,:) = 0.0
+ my_km = grd%km
+ if(drv%multiv .eq. 1) &
+ my_km = ros%kmchl
+
do m=1,bio%ncmp
do l=1,bio%nphy
- do k=1,grd%km
+ do k=1,my_km
do j=1,grd%jm
do i=1,grd%im
grd%chl_ad(i,j,k) = grd%chl_ad(i,j,k) + bio%cquot(i,j,k,l,m) * bio%pquot(i,j,k,l) * bio%phy_ad(i,j,k,l,m)
diff --git a/bio_str.f90 b/bio_str.f90
index fa2e57a..724ac21 100644
--- a/bio_str.f90
+++ b/bio_str.f90
@@ -40,13 +40,21 @@ MODULE bio_str
REAL(r8), POINTER :: pquot(:,:,:,:) ! Phytoplankton component quotas
REAL(r8), POINTER :: phy(:,:,:,:,:) ! biogeochemical variables
REAL(r8), POINTER :: phy_ad(:,:,:,:,:) ! biogeochemical adjoint variables
- REAL(r8), POINTER :: InitialChl(:,:,:) ! initial amount of chlorophyll
+ REAL(r8), POINTER :: InitialChl(:,:,:) ! initial amount of chlorophyll
+ REAL(r8), POINTER :: InitialNut(:,:,:,:) ! initial amount of nutrients
+ REAL(r8), POINTER :: covn3n_n1p(:,:,:) ! covariance n3n n1p
+ REAL(r8), POINTER :: covn3n_chl(:,:,:) ! covariance n3n chl
+ REAL(r8), POINTER :: covn1p_chl(:,:,:) ! covariance n3n chl
INTEGER :: nphy ! number of phytoplankton types
INTEGER :: ncmp ! No. of phytoplankton components
- LOGICAL :: ApplyConditions ! Apply conditions in snutell operations
-
+ LOGICAL :: ApplyConditions ! Apply conditions in snutell operations
+
+ INTEGER(i4) :: N3n ! N3n assimilation
+ INTEGER(i4) :: updateN1p ! N1p update based on N3n assimilation
+ INTEGER(i4) :: O2o ! O2o assimilation
+
END TYPE bio_t
TYPE (bio_t) :: bio
diff --git a/clean_mem.f90 b/clean_mem.f90
index 459ba2c..a05255b 100644
--- a/clean_mem.f90
+++ b/clean_mem.f90
@@ -51,6 +51,7 @@ subroutine clean_mem
DEALLOCATE ( arg%ib, arg%jb, arg%kb)
DEALLOCATE ( arg%pq1, arg%pq2, arg%pq3, arg%pq4)
DEALLOCATE ( arg%pq5, arg%pq6, arg%pq7, arg%pq8)
+ DEALLOCATE ( arg%par)
DEALLOCATE (grd%lon, grd%lat)
endif
@@ -72,11 +73,16 @@ subroutine clean_mem
DEALLOCATE ( rcf%sc)
DEALLOCATE(SendCountX3D, SendDisplX3D)
+ DEALLOCATE(SendCountX3D_chl, SendDisplX3D_chl)
DEALLOCATE(RecCountX3D, RecDisplX3D)
+ DEALLOCATE(RecCountX3D_chl, RecDisplX3D_chl)
DEALLOCATE(ChlExtended)
+ DEALLOCATE(ChlExtended_3d,N3nExtended_3d,O2oExtended_3d)
DEALLOCATE(SendBottom, RecTop)
DEALLOCATE(SendTop, RecBottom)
+ DEALLOCATE(SendTop_2d, RecBottom_2d)
+ DEALLOCATE(SendBottom_2d, RecTop_2d)
if(MyId .eq. 0) then
write(*,*) ' ALL MEMORY CLEAN'
diff --git a/cnv_inn.f90 b/cnv_inn.f90
index 2f723d5..ca686f0 100644
--- a/cnv_inn.f90
+++ b/cnv_inn.f90
@@ -35,13 +35,36 @@ subroutine cnv_inn
use eof_str
use ctl_str
use drv_str
+ use bio_str
implicit none
! --------
! Convert the control vector to v
call cnv_ctv
-
- call ver_hor
+ if (drv%multiv .eq. 0) then
+ if(drv%chl_assim .eq. 1) then
+ call ver_hor_chl
+ endif
+ if(drv%nut .eq. 1) then
+ if(bio%N3n .eq. 1) then
+ call ver_hor_nut(grd%n3n, grd%n3n_ad,'N')
+ endif
+ if(bio%O2o .eq. 1) then
+ call ver_hor_nut(grd%o2o, grd%o2o_ad,'O')
+ endif
+ endif
+ endif
+
+ if (drv%multiv .eq. 1) then
+ call ver_hor_chl
+ call ver_hor_nut(grd%n3n, grd%n3n_ad,'N')
+ endif
+
+ ! ---
+ ! Apply biological repartition of the chlorophyll
+ if((drv%chl_assim .eq. 1) .or. (drv%multiv .eq. 1)) &
+ call bio_mod
+
end subroutine cnv_inn
diff --git a/costf.f90 b/costf.f90
index 1047cbd..41570c1 100644
--- a/costf.f90
+++ b/costf.f90
@@ -36,16 +36,15 @@ subroutine costf
use eof_str
use ctl_str
use mpi_str
+ use bio_str
implicit none
integer :: ierr
! -------------------------------------------------------
! calculate backgorund cost term
! -------------------------------------------------------
-
ctl%f_b = 0.5 * dot_product( ctl%x_c, ctl%x_c)
call MPI_Allreduce(MPI_IN_PLACE, ctl%f_b, 1, MPI_REAL8, MPI_SUM, Var3DCommunicator, ierr)
- ! write(*,*) 'COSTF f_b = ', ctl%f_b
! -------------------------------------------------------
! calculate observational cost term
@@ -56,8 +55,29 @@ subroutine costf
call cnv_ctv
! --------
- ! Control to physical space
- call ver_hor
+ ! Control to physical space
+ if (drv%multiv.eq.0) then
+ if(drv%chl_assim .eq. 1) then
+ call ver_hor_chl
+ endif
+ if(drv%nut .eq. 1) then
+ if(bio%N3n .eq. 1) then
+ call ver_hor_nut(grd%n3n, grd%n3n_ad, 'N')
+ endif
+ if(bio%O2o .eq. 1) then
+ call ver_hor_nut(grd%o2o, grd%o2o_ad, 'O')
+ endif
+ endif
+
+ else if(drv%multiv .eq. 1) then
+ call ver_hor_chl
+ call ver_hor_nut(grd%n3n, grd%n3n_ad, 'N')
+ endif
+
+ ! ---
+ ! Apply biological repartition of the chlorophyll
+ if((drv%chl_assim .eq. 1) .or. (drv%multiv .eq. 1)) &
+ call bio_mod
! --------
! Apply observational operators
@@ -93,10 +113,31 @@ subroutine costf
! Observational operators
call obsop_ad
+ ! ---
+ ! Apply biological repartition of the chlorophyll
+ if((drv%chl_assim .eq. 1) .or. (drv%multiv .eq. 1)) &
+ call bio_mod_ad
+
! --------
- ! Control to physical space
- call ver_hor_ad
-
+ ! Control to physical space
+ if (drv%multiv .eq. 0) then
+ if(drv%chl_assim .eq. 1) then
+ call ver_hor_chl_ad
+ endif
+ if(drv%nut .eq. 1) then
+ if(bio%N3n .eq. 1) then
+ call ver_hor_nut_ad(grd%n3n, grd%n3n_ad, 'N')
+ endif
+ if(bio%O2o .eq. 1) then
+ call ver_hor_nut_ad(grd%o2o, grd%o2o_ad, 'O')
+ endif
+ endif
+
+ else if(drv%multiv .eq. 1) then
+ call ver_hor_chl_ad
+ call ver_hor_nut_ad(grd%n3n, grd%n3n_ad, 'N')
+ call veof_multiv_ad
+ endif
! write(*,*) 'COSTF sum(ro_ad) = ' , sum(grd%ro_ad)
! --------
! Convert the control vector
diff --git a/cp_chl_stat.f90 b/cp_chl_stat.f90
new file mode 100644
index 0000000..d0e0b7c
--- /dev/null
+++ b/cp_chl_stat.f90
@@ -0,0 +1,132 @@
+subroutine cp_chl_stat
+
+ use set_knd
+ use grd_str
+ use drv_str
+ use mpi_str
+ use bio_str
+ use pnetcdf
+ use da_params
+
+ implicit none
+
+ INTEGER(i4) :: ncid, ierr, i, j, k, l, m, doVariable
+ INTEGER(i4) :: idP, iVar
+ INTEGER(I4) :: xid,yid,depid,timeId, idTim
+ INTEGER :: system, SysErr
+
+ INTEGER(kind=MPI_OFFSET_KIND) :: global_im, global_jm, global_km, MyTime
+ INTEGER(KIND=MPI_OFFSET_KIND) :: MyCountSingle(1), MyStartSingle(1)
+ CHARACTER(LEN=46) :: BioRestart
+ CHARACTER(LEN=47) :: BioRestartLong
+ CHARACTER(LEN=6) :: MyVarName
+ ! LOGICAL, ALLOCATABLE :: MyConditions(:,:,:,:)
+
+ ! bug fix Intel 2018
+ real(r4), allocatable, dimension(:,:,:,:) :: DumpBio
+ integer(KIND=MPI_OFFSET_KIND) :: MyStart_4d(4), MyCount_4d(4)
+
+ real(r8) :: TimeArr(1)
+
+
+ MyStart_4d(1:3) = MyStart(:)
+ MyStart_4d(4) = 1
+ MyCount_4d(1:3) = MyCount(:)
+ MyCount_4d(4) = 1
+
+
+ ALLOCATE(DumpBio(grd%im,grd%jm,grd%km,1)); DumpBio(:,:,:,:) = 1.e20
+ ! ALLOCATE(MyConditions(grd%im,grd%jm,grd%km,bio%nphy))
+
+ if(MyId .eq. 0) then
+ write(drv%dia,*) 'writing chl structure (only copy from RSTbefore)'
+ write(*,*) 'writing chl structure (only copy from RSTbefore)'
+ endif
+
+ global_im = GlobalRow
+ global_jm = GlobalCol
+ global_km = grd%km
+ MyTime = 1
+
+ MyCountSingle(1) = 1
+ MyStartSingle(1) = 1
+ TimeArr(1) = DA_JulianDate
+
+ do m=1,bio%ncmp
+ do l=1,bio%nphy
+ iVar = l + bio%nphy*(m-1)
+ doVariable = 1
+
+ if(iVar .gt. NPhytoVar) then
+ if(MyId .eq. 0) &
+ write(*,*) "Warning: Variable not in the Phyto list ", DA_VarList(iVar)
+ doVariable = 0
+ endif
+
+ if(doVariable .eq. 1) then
+ BioRestart = 'RST_after.'//ShortDate//'.'//DA_VarList(iVar)//'.nc'
+ BioRestartLong = 'RST_after.'//DA_DATE//'.'//DA_VarList(iVar)//'.nc'
+
+ if(drv%Verbose .eq. 1 .and. MyId .eq. 0) &
+ print*, "Writing Chl Restart ", BioRestart
+
+ ierr = nf90mpi_create(Var3DCommunicator, BioRestart, NF90_CLOBBER, MPI_INFO_NULL, ncid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_create '//BioRestart, ierr)
+
+ ierr = nf90mpi_def_dim(ncid,'x',global_im ,xid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_dim longitude ', ierr)
+ ierr = nf90mpi_def_dim(ncid,'y' ,global_jm ,yid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_dim latitude ', ierr)
+ ierr = nf90mpi_def_dim(ncid,'z' ,global_km, depid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_dim depth ', ierr)
+ ierr = nf90mpi_def_dim(ncid,'time',MyTime ,timeId)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_dim time ', ierr)
+
+ MyVarName='TRN'//DA_VarList(iVar)
+
+ ierr = nf90mpi_def_var(ncid, MyVarName, nf90_float, (/xid,yid,depid,timeId/), idP )
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_var', ierr)
+
+ ierr = nf90mpi_def_var(ncid,'time' , nf90_double, (/timeid/) , idTim)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_var', ierr)
+ ierr = nf90mpi_put_att(ncid,idP , 'missing_value',1.e+20)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_put_att', ierr)
+
+ ierr = nf90mpi_enddef(ncid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_enddef'//DA_VarList(iVar), ierr)
+
+ do k=1,grd%km
+ do j=1,grd%jm
+ do i=1,grd%im
+
+ if(bio%InitialChl(i,j,k) .lt. 1.e20) then
+ DumpBio(i,j,k,1) = bio%pquot(i,j,k,l)*bio%cquot(i,j,k,l,m)*bio%InitialChl(i,j,k)
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ ierr = nf90mpi_put_var_all(ncid,idP,DumpBio,MyStart_4d,MyCount_4d)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_put_var_all '//DA_VarList(iVar), ierr)
+
+ ierr = nf90mpi_put_var_all(ncid,idTim,TimeArr,MyStartSingle,MyCountSingle)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_put_var_all '//DA_VarList(iVar), ierr)
+
+ ierr = nf90mpi_close(ncid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_close '//BioRestart, ierr)
+
+ call MPI_Barrier(Var3DCommunicator, ierr)
+ ! only process 0 creates link to restart files
+ if(MyId .eq. 0) then
+ SysErr = system("ln -sf $PWD/"//BioRestart//" "//BioRestartLong)
+ if(SysErr /= 0) call MPI_Abort(MPI_COMM_WORLD, -1, SysErr)
+ endif
+ endif ! on doVariable
+ enddo ! l
+ enddo ! m
+
+ DEALLOCATE(DumpBio)
+ ! DEALLOCATE(DumpBio, ValuesToTest, MyConditions)
+
+end subroutine cp_chl_stat
diff --git a/cp_nut_stat.f90 b/cp_nut_stat.f90
new file mode 100644
index 0000000..c62c88d
--- /dev/null
+++ b/cp_nut_stat.f90
@@ -0,0 +1,127 @@
+subroutine cp_nut_stat
+
+ use set_knd
+ use grd_str
+ use drv_str
+ use mpi_str
+ use bio_str
+ use pnetcdf
+ use da_params
+
+ implicit none
+
+ INTEGER(i4) :: ncid, ierr, i, j, k, l
+ INTEGER(i4) :: idP, iVar
+ INTEGER(I4) :: xid,yid,depid,timeId, idTim
+ INTEGER :: system, SysErr
+
+ INTEGER(kind=MPI_OFFSET_KIND) :: global_im, global_jm, global_km, MyTime
+ INTEGER(KIND=MPI_OFFSET_KIND) :: MyCountSingle(1), MyStartSingle(1)
+ CHARACTER(LEN=46) :: BioRestart
+ CHARACTER(LEN=47) :: BioRestartLong
+ CHARACTER(LEN=6) :: MyVarName
+ ! LOGICAL, ALLOCATABLE :: MyConditions(:,:,:,:)
+
+ ! bug fix Intel 2018
+ real(r4), allocatable, dimension(:,:,:,:) :: DumpBio
+ integer(KIND=MPI_OFFSET_KIND) :: MyStart_4d(4), MyCount_4d(4)
+
+ real(r8) :: TimeArr(1)
+
+
+ MyStart_4d(1:3) = MyStart(:)
+ MyStart_4d(4) = 1
+ MyCount_4d(1:3) = MyCount(:)
+ MyCount_4d(4) = 1
+
+
+ ALLOCATE(DumpBio(grd%im,grd%jm,grd%km,1)); DumpBio(:,:,:,:) = 1.e20
+ ! ALLOCATE(MyConditions(grd%im,grd%jm,grd%km,bio%nphy))
+
+ if(MyId .eq. 0) then
+ write(drv%dia,*) 'writing nut structure (only copy from RSTbefore)'
+ write(*,*) 'writing nut structure (only copy from RSTbefore)'
+ endif
+
+ global_im = GlobalRow
+ global_jm = GlobalCol
+ global_km = grd%km
+ MyTime = 1
+
+ MyCountSingle(1) = 1
+ MyStartSingle(1) = 1
+ TimeArr(1) = DA_JulianDate
+
+
+ do l=1,NNVar
+ iVar = NPhytoVar + l
+
+ if(iVar .gt. NBioVar) then
+ if(MyId .eq. 0) &
+ write(*,*) "Warning: Reading a variable not in the DA_VarList!"
+ endif
+
+ BioRestart = 'RST_after.'//ShortDate//'.'//DA_VarList(iVar)//'.nc'
+ BioRestartLong = 'RST_after.'//DA_DATE//'.'//DA_VarList(iVar)//'.nc'
+
+ if(drv%Verbose .eq. 1 .and. MyId .eq. 0) &
+ print*, "Writing Nut Restart ", BioRestart
+
+ ierr = nf90mpi_create(Var3DCommunicator, BioRestart, NF90_CLOBBER, MPI_INFO_NULL, ncid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_create '//BioRestart, ierr)
+
+ ierr = nf90mpi_def_dim(ncid,'x',global_im ,xid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_dim longitude ', ierr)
+ ierr = nf90mpi_def_dim(ncid,'y' ,global_jm ,yid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_dim latitude ', ierr)
+ ierr = nf90mpi_def_dim(ncid,'z' ,global_km, depid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_dim depth ', ierr)
+ ierr = nf90mpi_def_dim(ncid,'time',MyTime ,timeId)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_dim time ', ierr)
+
+ MyVarName='TRN'//DA_VarList(iVar)
+
+ ierr = nf90mpi_def_var(ncid, MyVarName, nf90_float, (/xid,yid,depid,timeId/), idP )
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_var', ierr)
+
+ ierr = nf90mpi_def_var(ncid,'time' , nf90_double, (/timeid/) , idTim)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_var', ierr)
+ ierr = nf90mpi_put_att(ncid,idP , 'missing_value',1.e+20)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_put_att', ierr)
+
+ ierr = nf90mpi_enddef(ncid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_enddef'//DA_VarList(iVar), ierr)
+
+ do k=1,grd%km
+ do j=1,grd%jm
+ do i=1,grd%im
+
+ if(bio%InitialNut(i,j,k,1) .lt. 1.e20) then
+ DumpBio(i,j,k,1) = bio%InitialNut(i,j,k,l)
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ ierr = nf90mpi_put_var_all(ncid,idP,DumpBio,MyStart_4d,MyCount_4d)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_put_var_all '//DA_VarList(iVar), ierr)
+
+ ierr = nf90mpi_put_var_all(ncid,idTim,TimeArr,MyStartSingle,MyCountSingle)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_put_var_all '//DA_VarList(iVar), ierr)
+
+ ierr = nf90mpi_close(ncid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_close '//BioRestart, ierr)
+
+ call MPI_Barrier(Var3DCommunicator, ierr)
+ ! only process 0 creates link to restart files
+ if(MyId .eq. 0) then
+ SysErr = system("ln -sf $PWD/"//BioRestart//" "//BioRestartLong)
+ if(SysErr /= 0) call MPI_Abort(MPI_COMM_WORLD, -1, SysErr)
+ endif
+ enddo ! l
+
+ DEALLOCATE(DumpBio)
+ ! DEALLOCATE(DumpBio, ValuesToTest, MyConditions)
+
+end subroutine cp_nut_stat
diff --git a/cp_o2o_stat.f90 b/cp_o2o_stat.f90
new file mode 100644
index 0000000..4a56fbd
--- /dev/null
+++ b/cp_o2o_stat.f90
@@ -0,0 +1,125 @@
+subroutine cp_o2o_stat
+
+ use set_knd
+ use grd_str
+ use drv_str
+ use mpi_str
+ use bio_str
+ use pnetcdf
+ use da_params
+
+ implicit none
+
+ INTEGER(i4) :: ncid, ierr, i, j, k, l
+ INTEGER(i4) :: idP, iVar
+ INTEGER(I4) :: xid,yid,depid,timeId, idTim
+ INTEGER :: system, SysErr
+
+ INTEGER(kind=MPI_OFFSET_KIND) :: global_im, global_jm, global_km, MyTime
+ INTEGER(KIND=MPI_OFFSET_KIND) :: MyCountSingle(1), MyStartSingle(1)
+ CHARACTER(LEN=46) :: BioRestart
+ CHARACTER(LEN=47) :: BioRestartLong
+ CHARACTER(LEN=6) :: MyVarName
+ ! LOGICAL, ALLOCATABLE :: MyConditions(:,:,:,:)
+
+ ! bug fix Intel 2018
+ real(r4), allocatable, dimension(:,:,:,:) :: DumpBio
+ integer(KIND=MPI_OFFSET_KIND) :: MyStart_4d(4), MyCount_4d(4)
+
+ real(r8) :: TimeArr(1)
+
+
+ MyStart_4d(1:3) = MyStart(:)
+ MyStart_4d(4) = 1
+ MyCount_4d(1:3) = MyCount(:)
+ MyCount_4d(4) = 1
+
+
+ ALLOCATE(DumpBio(grd%im,grd%jm,grd%km,1)); DumpBio(:,:,:,:) = 1.e20
+ ! ALLOCATE(MyConditions(grd%im,grd%jm,grd%km,bio%nphy))
+
+ if(MyId .eq. 0) then
+ write(drv%dia,*) 'writing o2o structure (only copy from RSTbefore)'
+ write(*,*) 'writing o2o structure (only copy from RSTbefore)'
+ endif
+
+ global_im = GlobalRow
+ global_jm = GlobalCol
+ global_km = grd%km
+ MyTime = 1
+
+ MyCountSingle(1) = 1
+ MyStartSingle(1) = 1
+ TimeArr(1) = DA_JulianDate
+
+
+ iVar = NPhytoVar + NNVar + 1
+
+ if(iVar .gt. NBioVar) then
+ if(MyId .eq. 0) &
+ write(*,*) "Warning: Reading a variable not in the DA_VarList!"
+ endif
+
+ BioRestart = 'RST_after.'//ShortDate//'.'//DA_VarList(iVar)//'.nc'
+ BioRestartLong = 'RST_after.'//DA_DATE//'.'//DA_VarList(iVar)//'.nc'
+
+ if(drv%Verbose .eq. 1 .and. MyId .eq. 0) &
+ print*, "Writing O2o Restart ", BioRestart
+
+ ierr = nf90mpi_create(Var3DCommunicator, BioRestart, NF90_CLOBBER, MPI_INFO_NULL, ncid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_create '//BioRestart, ierr)
+
+ ierr = nf90mpi_def_dim(ncid,'x',global_im ,xid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_dim longitude ', ierr)
+ ierr = nf90mpi_def_dim(ncid,'y' ,global_jm ,yid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_dim latitude ', ierr)
+ ierr = nf90mpi_def_dim(ncid,'z' ,global_km, depid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_dim depth ', ierr)
+ ierr = nf90mpi_def_dim(ncid,'time',MyTime ,timeId)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_dim time ', ierr)
+
+ MyVarName='TRN'//DA_VarList(iVar)
+
+ ierr = nf90mpi_def_var(ncid, MyVarName, nf90_float, (/xid,yid,depid,timeId/), idP )
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_var', ierr)
+
+ ierr = nf90mpi_def_var(ncid,'time' , nf90_double, (/timeid/) , idTim)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_var', ierr)
+ ierr = nf90mpi_put_att(ncid,idP , 'missing_value',1.e+20)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_put_att', ierr)
+
+ ierr = nf90mpi_enddef(ncid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_enddef'//DA_VarList(iVar), ierr)
+
+ do k=1,grd%km
+ do j=1,grd%jm
+ do i=1,grd%im
+
+ if(bio%InitialNut(i,j,k,NNVar+1) .lt. 1.e20) then
+ DumpBio(i,j,k,1) = bio%InitialNut(i,j,k,NNVar+1)
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ ierr = nf90mpi_put_var_all(ncid,idP,DumpBio,MyStart_4d,MyCount_4d)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_put_var_all '//DA_VarList(iVar), ierr)
+
+ ierr = nf90mpi_put_var_all(ncid,idTim,TimeArr,MyStartSingle,MyCountSingle)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_put_var_all '//DA_VarList(iVar), ierr)
+
+ ierr = nf90mpi_close(ncid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_close '//BioRestart, ierr)
+
+ call MPI_Barrier(Var3DCommunicator, ierr)
+ ! only process 0 creates link to restart files
+ if(MyId .eq. 0) then
+ SysErr = system("ln -sf $PWD/"//BioRestart//" "//BioRestartLong)
+ if(SysErr /= 0) call MPI_Abort(MPI_COMM_WORLD, -1, SysErr)
+ endif
+
+ DEALLOCATE(DumpBio)
+ ! DEALLOCATE(DumpBio, ValuesToTest, MyConditions)
+
+end subroutine cp_o2o_stat
diff --git a/da_params.f90 b/da_params.f90
index d373e16..d69bcc5 100644
--- a/da_params.f90
+++ b/da_params.f90
@@ -7,23 +7,29 @@ MODULE DA_PARAMS
character (LEN=17) :: DA_DATE != '20130102-120000'
character (LEN=15) :: ShortDate != '20130102-120000'
integer :: jpk_200 != 26
- integer :: NBioVar ! number of biological variables
+ integer :: NPhytoVar ! number of phytoplankton variables
+ integer :: NNVar ! number of non-phytoplankton variables
+ integer :: NNutVar ! number of nutrient variables
+ integer :: NBioVar ! number of bio variables
CHARACTER(LEN=3), allocatable :: DA_VarList(:) ! name of DA biological variables
- integer :: DA_JulianDate ! julian date
+ double precision :: DA_JulianDate ! julian date
CONTAINS
SUBROUTINE SET_DA_PARAMS
- DA_DATE = '20130101-12:00:00'
+ DA_DATE = '20150101-00:00:00'
ShortDate = DA_DATE(1:11)//DA_DATE(13:14)//DA_DATE(16:17)
- jpk_200 = 26
- NBioVar = 17
+ jpk_200 = 60
+ NPhytoVar = 17
+ NNutVar = 3
+ NNVar = 2
+ NBioVar = NPhytoVar + NNutVar
allocate(DA_VarList(NBioVar))
! DA_VarList init
- ! It must be consistent with NBioVar value
+ ! It must be consistent with NPhytoVar and NNutVar values
DA_VarList( 1)='P1l'
DA_VarList( 2)='P2l'
@@ -47,6 +53,14 @@ SUBROUTINE SET_DA_PARAMS
DA_VarList(17)='P1s'
+ DA_VarList(18)='N3n'
+ DA_VarList(19)='N1p'
+
+ DA_VarList(20)='O2o'
+
+ ! DA_VarList(1)='N3n'
+ ! DA_VarList(2)='N1p'
+ ! DA_VarList(1)='O2o'
END SUBROUTINE SET_DA_PARAMS
@@ -56,4 +70,4 @@ SUBROUTINE CLEAN_DA_PARAMS
END SUBROUTINE CLEAN_DA_PARAMS
-END MODULE DA_PARAMS
\ No newline at end of file
+END MODULE DA_PARAMS
diff --git a/def_cov.f90 b/def_cov.f90
index 02e0a42..bf81477 100644
--- a/def_cov.f90
+++ b/def_cov.f90
@@ -35,10 +35,13 @@ subroutine def_cov
use cns_str
use rcfl
use mpi_str
+ use bio_str
+ use da_params
implicit none
INTEGER(i4) :: k, nspl, i, j, kk, l
+ INTEGER(i4) :: nsplvec(1)
REAL(r8) :: E, dst, Lmean, mean_rad
REAL(r8) , ALLOCATABLE :: sfct(:), al(:), bt(:)
INTEGER(i4) , ALLOCATABLE :: jnxx(:)
@@ -107,6 +110,7 @@ subroutine def_cov
!nspl = max(grd%jm,grd%im)
nspl = max(GlobalRow,GlobalCol)
+ nsplvec(:) = nspl
ALLOCATE ( sfct(nspl)) ; sfct = huge(sfct(1))
ALLOCATE ( jnxx(nspl)) ; jnxx = huge(jnxx(1))
ALLOCATE ( al(nspl)) ; al = huge(al(1))
@@ -153,8 +157,8 @@ subroutine def_cov
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)
+ call rcfl_y_init ( 1, nspl, 1, nspl, al, bt, sfct, jnxx, nsplvec)
+ call rcfl_y_ad_init ( 1, nspl, 1, nspl, al, bt, sfct, jnxx, nsplvec)
rcf%sc(k,l) = sfct(nspl/2+1)
enddo
enddo
@@ -231,8 +235,8 @@ subroutine def_cov
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)
+ call rcfl_y_init ( 1, nspl, 1, nspl, al, bt, sfct, jnxx, nsplvec)
+ call rcfl_y_ad_init ( 1, nspl, 1, nspl, al, bt, sfct, jnxx, nsplvec)
rcf%sc(k,l) = sfct(nspl/2+1)
enddo
enddo
@@ -329,6 +333,57 @@ subroutine def_cov
enddo
+
+
+ if (drv%multiv.eq.1) then
+ grd%imax_chl = 0
+ grd%jmax_chl = 0
+
+ do k = 1, ros%kmchl
+
+ grd%imx(k) = 0
+ do j = 1, localCol
+ kk = grd%istp(1,j,k)
+ if( grd%global_msk(1,j+GlobalColOffset,k).eq.1. ) kk = kk + 1
+ grd%inx(1,j,k) = kk
+ do i = 2, GlobalRow
+ if( grd%global_msk(i,j+GlobalColOffset,k).eq.0. .and. grd%global_msk(i-1,j+GlobalColOffset,k).eq.1. ) then
+ kk = kk + grd%istp(i,j,k)
+ else if( grd%global_msk(i,j+GlobalColOffset,k).eq.1. .and. grd%global_msk(i-1,j+GlobalColOffset,k).eq.0. ) then
+ kk = kk + grd%istp(i,j,k) + 1
+ else if( grd%global_msk(i,j+GlobalColOffset,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(GlobalRow,j,k))
+ enddo
+ grd%imax = max( grd%imax, grd%imx(k))
+
+ grd%jmx(k) = 0
+ do i = 1, localRow
+ kk = grd%jstp(i,1,k)
+ if( grd%global_msk(i+GlobalRowOffset,1,k).eq.1. ) kk = kk + 1
+ grd%jnx(i,1,k) = kk
+ do j = 2, GlobalCol
+ if( grd%global_msk(i+GlobalRowOffset,j,k).eq.0. .and. grd%global_msk(i+GlobalRowOffset,j-1,k).eq.1. ) then
+ kk = kk + grd%jstp(i,j,k)
+ else if( grd%global_msk(i+GlobalRowOffset,j,k).eq.1. .and. grd%global_msk(i+GlobalRowOffset,j-1,k).eq.0. ) then
+ kk = kk + grd%jstp(i,j,k) + 1
+ else if( grd%global_msk(i+GlobalRowOffset,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,GlobalCol,k))
+ enddo
+ grd%jmax = max( grd%jmax, grd%jmx(k))
+
+ enddo
+ call MPI_Allreduce(MPI_IN_PLACE, grd%imax_chl, 1, MPI_INT, MPI_MAX, Var3DCommunicator, ierr)
+ call MPI_Allreduce(MPI_IN_PLACE, grd%jmax_chl, 1, MPI_INT, MPI_MAX, Var3DCommunicator, ierr)
+ endif ! if drv%multiv
+
call MPI_Allreduce(MPI_IN_PLACE, grd%imax, 1, MPI_INT, MPI_MAX, Var3DCommunicator, ierr)
call MPI_Allreduce(MPI_IN_PLACE, grd%jmax, 1, MPI_INT, MPI_MAX, Var3DCommunicator, ierr)
@@ -395,13 +450,53 @@ subroutine def_cov
ros%kmt = grd%km
- call rdeofs
+ if (drv%multiv .eq. 0) then
+ ros%neof_multi = 0
+
+ if(drv%chl_assim .eq. 1) then
+ call rdeofs_chl
+ else
+ ros%neof_chl = 0
+ endif
+
+ if(drv%nut .eq. 1) then
+ if(bio%n3n .eq. 1) then
+ call rdeofs_n3n
+ else
+ ros%neof_n3n = 0
+ endif
+ if(bio%o2o .eq. 1) then
+ call rdeofs_o2o
+ else
+ ros%neof_o2o = 0
+ endif
+ ros%neof_nut = ros%neof_n3n + ros%neof_o2o
+ else
+ ros%neof_nut = 0
+ endif
+
+ else if(drv%multiv .eq. 1) then
+ ros%neof_chl = 0
+ ros%neof_n3n = 0
+ ros%neof_o2o = 0
+ call rdeofs_multi
+ endif
+
+
+ ros%neof = ros%neof_multi + ros%neof_chl + ros%neof_nut
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
- if(MyId .eq. 0) &
+ if(MyId .eq. 0) then
write(*,*) 'rcfl allocation :', grd%jmax, grd%imax, nthreads
+ write(*,*) 'Total number of eofs: ', ros%neof
+ write(*,*) ' - multi number of eofs: ', ros%neof_multi
+ write(*,*) ' - chl number of eofs: ', ros%neof_chl
+ write(*,*) ' - nut number of eofs: ', ros%neof_nut
+ write(*,*) ' - n3n number of eofs: ', ros%neof_n3n
+ write(*,*) ' - o2o number of eofs: ', ros%neof_o2o
+ endif
ALLOCATE ( a_rcx(localCol,grd%imax,nthreads)) ; a_rcx = huge(a_rcx(1,1,1))
ALLOCATE ( b_rcx(localCol,grd%imax,nthreads)) ; b_rcx = huge(b_rcx(1,1,1))
ALLOCATE ( c_rcx(localCol,grd%imax,nthreads)) ; c_rcx = huge(c_rcx(1,1,1))
@@ -423,7 +518,33 @@ subroutine def_cov
! read ratios for biological repartition
! of the chlorophyll
- if(drv%bio_assim .eq. 1) &
- call readBioStat
+ if(drv%multiv .eq. 0) then
+ if(drv%chl_assim.eq.1) then
+ call readChlStat
+ if ((drv%nut .eq. 0) .and. (NNutVar .gt. 0)) then
+ call readNutStat
+ if (drv%chl_upnut.eq.1) then
+ call readNutCov
+ call readChlNutCov
+ endif
+ endif
+ endif
+
+ if(drv%nut.eq.1) then
+ call readNutStat
+ if(bio%N3n.eq.1 .AND. bio%updateN1p.eq.1) then
+ call readNutCov
+ endif
+ if(drv%chl_assim.eq.0) then
+ call readChlStat
+ endif
+ endif
+
+ else if (drv%multiv.eq.1) then
+ call readChlStat
+ call readNutStat
+ if(bio%updateN1p.eq.1) &
+ call readNutCov
+ endif
end subroutine def_cov
diff --git a/def_nml.f90 b/def_nml.f90
index 7f5858e..f99c065 100644
--- a/def_nml.f90
+++ b/def_nml.f90
@@ -40,17 +40,14 @@ subroutine def_nml
implicit none
- LOGICAL :: read_eof, ApplyConditions
- INTEGER(i4) :: neof, nreg, rcf_ntr
- INTEGER(i4) :: ctl_m, bio_assim
- INTEGER(i4) :: biol, bphy, nphyto, uniformL, anisL, verbose
- REAL(r8) :: rcf_L, ctl_tol, ctl_per, rcf_efc, chl_dep
- INTEGER(i4) :: argo, sat_obs, ncmp
+ LOGICAL :: read_eof
+ INTEGER(i4) :: neof_chl, neof_n3n, neof_o2o, nreg, rcf_ntr
+ INTEGER(i4) :: neof_multi, kmchl, kmnit
+ INTEGER(i4) :: verbose
+ REAL(r8) :: rcf_L, ctl_tol, ctl_per, rcf_efc
- NAMELIST /ctllst/ ctl_tol, ctl_per
- NAMELIST /covlst/ neof, nreg, read_eof, rcf_ntr, rcf_L, rcf_efc
- NAMELIST /biolst/ bio_assim, nphyto, chl_dep, ncmp, ApplyConditions
- NAMELIST /params/ sat_obs, argo, uniformL, anisL, verbose
+ NAMELIST /ctllst/ ctl_tol, ctl_per, verbose
+ NAMELIST /covlst/ neof_chl, neof_n3n, neof_o2o, neof_multi, kmchl, kmnit, nreg, read_eof, rcf_ntr, rcf_L, rcf_efc
! -------------------------------------------------------------------
@@ -60,7 +57,7 @@ subroutine def_nml
drv%dia = 12
if(MyId .eq. 0) then
- open ( drv%dia, file='OceanVar.diagnostics', form='formatted' )
+ open ( drv%dia, file='BioVar.diagnostics', form='formatted' )
endif
!---------------------------------------------------------------------
@@ -81,15 +78,15 @@ subroutine def_nml
write(drv%dia,*) '------------------------------------------------------------'
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
+ write(drv%dia,*) ' Add verbose on standard output verbose = ', verbose
endif
- ! ctl%m = ctl_m
ctl%pgtol = ctl_tol
ctl%pgper = ctl_per
+ drv%Verbose = verbose
! ---
read(11,covlst)
@@ -99,7 +96,12 @@ subroutine def_nml
write(drv%dia,*) '------------------------------------------------------------'
write(drv%dia,*) '------------------------------------------------------------'
write(drv%dia,*) ' COVARIANCE NAMELIST INPUT: '
- write(drv%dia,*) ' Number of EOFs: neof = ', neof
+ write(drv%dia,*) ' Number of EOFs for chl: neof_chl = ', neof_chl
+ write(drv%dia,*) ' Number of EOFs for N3n: neof_n3n = ', neof_n3n
+ write(drv%dia,*) ' Number of EOFs for O2o: neof_o2o = ', neof_o2o
+ write(drv%dia,*) ' Number of multivariate EOFs: neof_multi = ', neof_multi
+ write(drv%dia,*) ' Chl Nlevels in multi EOFs: kmchl = ', kmchl
+ write(drv%dia,*) ' Nit Nlevels in multi EOFs: kmnit = ', kmnit
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
@@ -108,60 +110,19 @@ subroutine def_nml
endif
- ros%neof = neof
+ close(11)
+
+ ros%neof_chl = neof_chl
+ ros%neof_n3n = neof_n3n
+ ros%neof_o2o = neof_o2o
+ ros%neof_multi = neof_multi
+ ros%kmchl = kmchl
+ ros%kmnit = kmnit
ros%nreg = nreg
ros%read_eof = read_eof
rcf%ntr = rcf_ntr
rcf%L = rcf_L
rcf%efc = rcf_efc
-! ---
- read(11,biolst)
-
- if(MyId .eq. 0) then
-
- write(drv%dia,*) '------------------------------------------------------------'
- write(drv%dia,*) '------------------------------------------------------------'
- write(drv%dia,*) ' BIOLOGY NAMELIST INPUT: '
- write(drv%dia,*) ' Biological repartition of the chlorophyll = ', bio_assim
- write(drv%dia,*) ' Number of phytoplankton species nphyt = ', nphyto
- write(drv%dia,*) ' Minimum depth for chlorophyll chl_dep = ', chl_dep
- write(drv%dia,*) ' Number of phytoplankton components ncmp = ', ncmp
- write(drv%dia,*) ' Apply conditions flag ApplyConditions = ', ApplyConditions
-
- endif
-
- drv%bio_assim = bio_assim
- bio%nphy = nphyto
- sat%dep = chl_dep
- bio%ncmp = ncmp
- bio%ApplyConditions = ApplyConditions
-
- read(11,params)
-
- if(MyId .eq. 0) then
-
- write(drv%dia,*) '------------------------------------------------------------'
- write(drv%dia,*) '------------------------------------------------------------'
- write(drv%dia,*) ' PARAMETERS NAMELIST INPUT: '
- write(drv%dia,*) ' Read Satellite observations sat_obs = ', sat_obs
- write(drv%dia,*) ' Read ARGO float observations argo = ', argo
- write(drv%dia,*) ' Set uniform correlation radius uniformL = ', uniformL
- write(drv%dia,*) ' Set anisotropy on corr radius anisL = ', anisL
- write(drv%dia,*) ' Add verbose on standard output verbose = ', verbose
- write(drv%dia,*) '------------------------------------------------------------'
- write(drv%dia,*) '------------------------------------------------------------'
- write(drv%dia,*) ''
-
-
- endif
-
- close(11)
-
- drv%sat_obs = sat_obs
- drv%argo_obs = argo
- drv%uniformL = uniformL
- drv%anisL = anisL
- drv%Verbose = verbose
end subroutine def_nml
diff --git a/def_nml_multi.f90 b/def_nml_multi.f90
new file mode 100644
index 0000000..01a917c
--- /dev/null
+++ b/def_nml_multi.f90
@@ -0,0 +1,138 @@
+subroutine def_nml_multi
+
+!---------------------------------------------------------------------------
+! !
+! Copyright 2018 Anna Teruzzi, OGS, Trieste !
+! !
+! This file is part of 3DVarBio. !
+! 3DVarBio is based on OceanVar (Dobricic, 2006) !
+! !
+! 3DVarBio 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. !
+! !
+! 3DVarBio 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 !
+! for multi platform and multivariate DA !
+! (other general DA parameters are defined in def_nml.f90) !
+! !
+! Version 1: A. Teruzzi 2018 !
+!-----------------------------------------------------------------------
+
+
+ use set_knd
+ use drv_str
+ use grd_str
+ use obs_str
+ use eof_str
+ use cns_str
+ use ctl_str
+ use mpi_str
+ use bio_str
+ use da_params
+
+ implicit none
+
+ LOGICAL :: ApplyConditions
+ INTEGER(i4) :: chl_assim, chl_upnut, nut, multiv, N3n, O2o, updateN1p
+ INTEGER(i4) :: nphyto, uniformL, anisL
+ REAL(r8) :: chl_dep
+ INTEGER(i4) :: argo, sat_obs, ncmp
+
+ !NAMELIST /ctllst/ ctl_tol, ctl_per
+ !NAMELIST /covlst/ neof_chl, neof_n3n, neof_o2o, nreg, read_eof, rcf_ntr, rcf_L, rcf_efc
+ NAMELIST /biolst/ chl_assim, chl_upnut, nut, multiv, nphyto, chl_dep, ncmp, ApplyConditions, N3n, updateN1p, O2o
+ NAMELIST /params/ sat_obs, argo, uniformL, anisL
+
+
+! -------------------------------------------------------------------
+! Open a formatted file for the diagnostics
+! ---
+
+ drv%dia = 12
+
+ if(MyId .eq. 0) then
+ open ( drv%dia, file='OceanVar.dia_multinml.'//DA_DATE, form='formatted' )
+ endif
+
+!---------------------------------------------------------------------
+! Open the namelist
+! ---
+
+ open(11,file='satfloat.'//DA_DATE//'.nml',form='formatted')
+
+ ! ---
+
+ read(11,biolst)
+
+ if(MyId .eq. 0) then
+
+ write(drv%dia,*) '------------------------------------------------------------'
+ write(drv%dia,*) '------------------------------------------------------------'
+ write(drv%dia,*) ' BIOLOGY NAMELIST INPUT: '
+ write(drv%dia,*) ' Chlorophyll assimilation chl_assim = ', chl_assim
+ write(drv%dia,*) ' N3n update based on chl assimilation chl_upnut = ', chl_upnut
+ write(drv%dia,*) ' Nutrient assimilation nut = ', nut
+ write(drv%dia,*) ' Multivariate assimilation multiv = ', multiv
+ write(drv%dia,*) ' Number of phytoplankton species nphyt = ', nphyto
+ write(drv%dia,*) ' Minimum depth for chlorophyll chl_dep = ', chl_dep
+ write(drv%dia,*) ' Number of phytoplankton components ncmp = ', ncmp
+ write(drv%dia,*) ' Apply conditions flag ApplyConditions = ', ApplyConditions
+ write(drv%dia,*) ' N3n assimilation N3n = ', N3n
+ write(drv%dia,*) ' N1p update based on N3n assimilation updateN1p = ', updateN1p
+ write(drv%dia,*) ' O2o assimilation O2o = ', O2o
+
+ endif
+
+ drv%chl_assim = chl_assim
+ drv%chl_upnut = chl_upnut
+ drv%nut = nut
+ drv%multiv = multiv
+ bio%nphy = nphyto
+ sat%dep = chl_dep
+ bio%ncmp = ncmp
+ bio%ApplyConditions = ApplyConditions
+ bio%N3n = N3n
+ bio%updateN1p = updateN1p
+ bio%O2o = O2o
+
+ ! ---
+
+ read(11,params)
+
+ if(MyId .eq. 0) then
+
+ write(drv%dia,*) '------------------------------------------------------------'
+ write(drv%dia,*) '------------------------------------------------------------'
+ write(drv%dia,*) ' PARAMETERS NAMELIST INPUT: '
+ write(drv%dia,*) ' Read Satellite observations sat_obs = ', sat_obs
+ write(drv%dia,*) ' Read ARGO float observations argo = ', argo
+ write(drv%dia,*) ' Set uniform correlation radius uniformL = ', uniformL
+ write(drv%dia,*) ' Set anisotropy on corr radius anisL = ', anisL
+ write(drv%dia,*) '------------------------------------------------------------'
+ write(drv%dia,*) '------------------------------------------------------------'
+ write(drv%dia,*) ''
+
+
+ endif
+
+ close(11)
+
+ drv%sat_obs = sat_obs
+ drv%argo_obs = argo
+ drv%uniformL = uniformL
+ drv%anisL = anisL
+
+end subroutine def_nml_multi
diff --git a/drv_str.f90 b/drv_str.f90
index ef73c65..3e73d84 100644
--- a/drv_str.f90
+++ b/drv_str.f90
@@ -41,10 +41,13 @@ MODULE drv_str
INTEGER(i4) :: MyCounter ! Number of iteration done by Tao solver
INTEGER(i4) :: sat_obs ! Flag for the assimilation of the satellite observations
INTEGER(i4) :: argo_obs ! Flag for the assimilation of the argo float observations
- INTEGER(i4) :: bio_assim ! Flag for the biological repartition of the chlorophyll
+ INTEGER(i4) :: chl_assim ! Flag for the chlorophyll assimilation
+ INTEGER(i4) :: chl_upnut ! Flag for the update of nut based on chlorophyll assimilation
INTEGER(i4) :: uniformL ! Flag for setting uniform correlation radius (1 = non uniform)
INTEGER(i4) :: anisL ! Flag for setting anisotropy on correlation radius (1 = anisotropy)
INTEGER(i4) :: Verbose ! Flag for printing verbose output
+ INTEGER(i4) :: nut ! Flag for nutrient assimilation
+ INTEGER(i4) :: multiv ! Flag for multivariate assimilation
END TYPE drv_t
diff --git a/eof_str.f90 b/eof_str.f90
index a81b679..75cd61c 100644
--- a/eof_str.f90
+++ b/eof_str.f90
@@ -37,9 +37,16 @@ MODULE eof_str
TYPE eof_t
LOGICAL :: read_eof ! Read EOFs from file
- INTEGER(i4) :: neof ! No. of EOFs
+ INTEGER(i4) :: neof ! Total No. of EOFs
+ INTEGER(i4) :: neof_chl ! No. of EOFs for chl
+ INTEGER(i4) :: neof_nut ! No. of EOFs for nutrients
+ INTEGER(i4) :: neof_n3n ! No. of EOFs for N3n
+ INTEGER(i4) :: neof_o2o ! No. of EOFs for O2o
+ INTEGER(i4) :: neof_multi ! No. of EOFs for multivariate
INTEGER(i4) :: nreg ! No. of regions
INTEGER(i4) :: kmt ! No. of levels of EOFs
+ INTEGER(i4) :: kmchl ! No. of levels of multi EOFs for chl
+ INTEGER(i4) :: kmnit ! No. of levels of multi EOFs for nit
REAL(r8), POINTER :: evcr(:,:,:) ! Eigenvectors on regions
REAL(r8), POINTER :: evar(:,:) ! Eigenvalues on regions
REAL(r8), POINTER :: corr(:,:,:) ! Corelations on regions
@@ -47,8 +54,14 @@ MODULE eof_str
REAL(r8), POINTER :: evc(:,:,:,:) ! Eigenvectors
REAL(r8), POINTER :: eva(:,:,:) ! Eigenvalues
#else
- REAL(r8), POINTER :: evc(:,:,:) ! Eigenvectors
- REAL(r8), POINTER :: eva(:,:) ! Eigenvalues
+ REAL(r8), POINTER :: evc_chl(:,:,:) ! Eigenvectors
+ REAL(r8), POINTER :: eva_chl(:,:) ! Eigenvalues
+ REAL(r8), POINTER :: evc_n3n(:,:,:) ! Eigenvectors
+ REAL(r8), POINTER :: eva_n3n(:,:) ! Eigenvalues
+ REAL(r8), POINTER :: evc_o2o(:,:,:) ! Eigenvectors
+ REAL(r8), POINTER :: eva_o2o(:,:) ! Eigenvalues
+ REAL(r8), POINTER :: evc_multi(:,:,:) ! Eigenvectors
+ REAL(r8), POINTER :: eva_multi(:,:) ! Eigenvalues
#endif
diff --git a/filename_mod.f90 b/filename_mod.f90
index 30bab7f..dcf6e14 100644
--- a/filename_mod.f90
+++ b/filename_mod.f90
@@ -2,12 +2,18 @@ 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'
+character (LEN=1024) :: EOF_FILE_CHL != 'eofs_chl.nc'
+character (LEN=1024) :: EOF_FILE_N3N != 'eofs_n3n.nc'
+character (LEN=1024) :: EOF_FILE_O2O != 'eofs_o2o.nc'
+character (LEN=1024) :: EOF_FILE_MULTI != 'eofs_multi.nc'
+character (LEN=1024) :: STD_FILE_MULTI != 'std_multi.nc'
+character (LEN=1024) :: MISFIT_FILE != 'chl_mis.nc'
+character (LEN=1024) :: NUTCOV_FILE != 'crosscorrs.nc'
+character (LEN=1024) :: NUTCHLCOV_FILE != 'crosscorrs.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'
!laura
character (LEN=1024) :: RCORR_FILE != 'chl_rad_corr.nc'
character (LEN=1024) :: ARGO_FILE != 'argo_mis.dat'
@@ -18,18 +24,24 @@ MODULE FILENAMES
!
!
SUBROUTINE SETFILENAMES
-! !VAR_FILE='DA_static_data/MISFIT/VAR2D/var2D.05.nc'
+! !VAR_FILE='DA_static_data/VAR_SAT/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'
+EOF_FILE_CHL = 'eofs_chl.nc'
+EOF_FILE_N3N = 'eofs_n3n.nc'
+EOF_FILE_O2O = 'eofs_o2o.nc'
+EOF_FILE_MULTI = 'eofs_multi.nc'
+STD_FILE_MULTI = 'std_multi.nc'
+MISFIT_FILE = 'chl_mis.nc'
+NUTCOV_FILE = 'crosscorrs.nc'
+NUTCHLCOV_FILE = 'crosscorrs.nc'
+ CORR_FILE = 'corr.nc'
+ EIV_FILE = 'eiv.nc'
+ OBS_FILE = 'obs_1.dat' ! 'obs_'//fgrd//'.dat'
+ GRID_FILE = 'grid1.nc'! 'grid'//cgrd//'.nc'
!laura
- RCORR_FILE = 'chl_rad_corr.nc'
- ARGO_FILE = 'arg_mis.dat'
- ANIS_FILE = 'gradsal.nc'
+ RCORR_FILE = 'chl_rad_corr.nc'
+ ARGO_FILE = 'arg_mis.dat'
+ ANIS_FILE = 'gradsal.nc'
END SUBROUTINE SETFILENAMES
diff --git a/get_obs.f90 b/get_obs.f90
index c87cbc0..ed087a3 100644
--- a/get_obs.f90
+++ b/get_obs.f90
@@ -37,6 +37,8 @@ subroutine get_obs
arg%no = 0
sat%no = 0
+ arg%nc = 0
+ sat%nc = 0
! ----
diff --git a/get_obs_arg.f90 b/get_obs_arg.f90
index 8e58b73..7a45d6d 100644
--- a/get_obs_arg.f90
+++ b/get_obs_arg.f90
@@ -34,12 +34,14 @@ subroutine get_obs_arg
use obs_str
use mpi_str
use filenames
+ use bio_str
implicit none
INTEGER(i4) :: k
INTEGER(i4) :: i1, kk, i
REAL(r8), ALLOCATABLE, DIMENSION(:) :: TmpFlc, TmpPar, TmpLon, TmpLat
+ ! REAL(r8), ALLOCATABLE, DIMENSION(:) :: TmpDpt, TmpTim, TmpRes, TmpErr, TmpStd, TmpIno
REAL(r8), ALLOCATABLE, DIMENSION(:) :: TmpDpt, TmpTim, TmpRes, TmpErr, TmpIno
INTEGER(i4) :: GlobalArgNum, Counter, ierr
character(len=1024) :: filename
@@ -68,6 +70,7 @@ subroutine get_obs_arg
ALLOCATE( TmpLon(GlobalArgNum), TmpLat(GlobalArgNum))
ALLOCATE( TmpDpt(GlobalArgNum), TmpTim(GlobalArgNum))
ALLOCATE( TmpRes(GlobalArgNum), TmpErr(GlobalArgNum))
+! ALLOCATE( TmpStd(GlobalArgNum), TmpIno(GlobalArgNum))
ALLOCATE( TmpIno(GlobalArgNum))
if(MyId .eq. 0) then
@@ -77,7 +80,9 @@ subroutine get_obs_arg
TmpFlc(k), TmpPar(k), &
TmpLon(k), TmpLat(k), &
TmpDpt(k), TmpTim(k), &
- TmpRes(k), TmpErr(k), TmpIno(k)
+ TmpRes(k), TmpErr(k), &
+ ! TmpStd(k), TmpIno(k)
+ TmpIno(k)
end do
close (511)
endif
@@ -97,7 +102,11 @@ subroutine get_obs_arg
do k=1,GlobalArgNum
if( TmpLon(k) .ge. grd%lon(1,1) .and. TmpLon(k) .lt. grd%NextLongitude .and. &
TmpLat(k) .ge. grd%lat(1,1) .and. TmpLat(k) .lt. grd%lat(grd%im,grd%jm) ) then
- Counter = Counter + 1
+ if( (TmpPar(k).eq.0 .and. ((drv%chl_assim.eq.1).or.(drv%multiv.eq.1))) .or. &
+ (TmpPar(k).eq.1 .and. ((drv%nut.eq.1 .and.bio%n3n.eq.1).or.(drv%multiv.eq.1))) .or. &
+ (TmpPar(k).eq.2 .and. drv%nut.eq.1 .and. bio%o2o.eq.1) ) then
+ Counter = Counter + 1
+ endif
endif
enddo
@@ -111,6 +120,7 @@ subroutine get_obs_arg
ALLOCATE ( arg%inc(arg%no))
ALLOCATE ( arg%err(arg%no))
ALLOCATE ( arg%res(arg%no))
+! ALLOCATE ( arg%std(arg%no))
ALLOCATE ( arg%ib(arg%no), arg%jb(arg%no), arg%kb(arg%no))
ALLOCATE ( arg%pb(arg%no), arg%qb(arg%no), arg%rb(arg%no))
ALLOCATE ( arg%pq1(arg%no), arg%pq2(arg%no), arg%pq3(arg%no), arg%pq4(arg%no))
@@ -120,18 +130,23 @@ subroutine get_obs_arg
do k=1,GlobalArgNum
if( TmpLon(k) .ge. grd%lon(1,1) .and. TmpLon(k) .lt. grd%NextLongitude .and. &
TmpLat(k) .ge. grd%lat(1,1) .and. TmpLat(k) .lt. grd%lat(grd%im,grd%jm) ) then
- Counter = Counter + 1
- arg%flc(Counter) = TmpFlc(k)
- arg%par(Counter) = TmpPar(k)
- arg%lon(Counter) = TmpLon(k)
- arg%lat(Counter) = TmpLat(k)
- arg%dpt(Counter) = TmpDpt(k)
- arg%res(Counter) = TmpRes(k)
- arg%err(Counter) = TmpErr(k)
- arg%ino(Counter) = TmpIno(k)
+ if((TmpPar(k).eq.0 .and. (drv%chl_assim.eq.1 .or. drv%multiv.eq.1)) .or. &
+ (TmpPar(k).eq.1 .and. ((drv%nut.eq.1 .and. bio%n3n.eq.1).or.(drv%multiv.eq.1))) .or. &
+ (TmpPar(k).eq.2 .and. drv%nut.eq.1 .and. bio%o2o.eq.1)) then
+ Counter = Counter + 1
+ arg%flc(Counter) = TmpFlc(k)
+ arg%par(Counter) = TmpPar(k)
+ arg%lon(Counter) = TmpLon(k)
+ arg%lat(Counter) = TmpLat(k)
+ arg%dpt(Counter) = TmpDpt(k)
+ arg%res(Counter) = TmpRes(k)
+ arg%err(Counter) = TmpErr(k)
+ ! arg%std(Counter) = TmpStd(k)
+ arg%ino(Counter) = TmpIno(k)
+ endif
endif
- enddo
+ enddo
! DECOMMENT FOLLOWING TWO LINES TO MAKE FILTER TEST
! arg%res(:) = 1
@@ -185,6 +200,7 @@ subroutine get_obs_arg
DEALLOCATE( TmpLon, TmpLat)
DEALLOCATE( TmpDpt, TmpTim)
DEALLOCATE( TmpRes, TmpErr)
+! DEALLOCATE( TMPStd, TmpIno)
DEALLOCATE( TmpIno)
end subroutine get_obs_arg
@@ -203,12 +219,13 @@ subroutine int_par_arg
use set_knd
use drv_str
use grd_str
+ use eof_str
use obs_str
use mpi_str
implicit none
- INTEGER(i4) :: i, j, k, ierr
+ INTEGER(i4) :: i, j, k, ierr, kind, kk
INTEGER(i4) :: i1, j1, k1, idep
REAL(r8) :: p1, q1, r1
REAL(r8) :: msk4, div_x, div_y
@@ -271,7 +288,8 @@ subroutine int_par_arg
! ---
! Horizontal interpolation parameters for each masked grid
do k = 1,arg%no
- if(arg%flc(k) .eq. 1) then
+ if(arg%flg(k) .eq. 1) then
+ ! if(arg%flg(k) .eq. 1) then ! to verify that it works also in this case
i1=arg%ib(k)
p1=arg%pb(k)
@@ -346,6 +364,25 @@ subroutine int_par_arg
endif
enddo
+
+ ! Exclude observations below ros%kmchl in multivariate observations
+ if(drv%multiv.eq.1) then
+ do k=1,arg%no
+ if((arg%flc(k).eq.1).and.(arg%par(k).eq.0)) then
+ kind = grd%km-1
+ do kk = 1,grd%km-1
+ if( arg%dpt(k).ge.grd%dep(kk) .and. arg%dpt(k).lt.grd%dep(kk+1) ) then
+ kind = kk
+ else if ( arg%dpt(k).ge.0 .and. arg%dpt(k).lt.grd%dep(1)) then
+ kind = 1
+ endif
+ enddo
+ if(kind.gt.ros%kmchl) then
+ arg%flc(k)=0
+ end if
+ endif
+ enddo
+ endif
! ---
! Count good observations
@@ -366,7 +403,7 @@ subroutine int_par_arg
print*,'Good argo observations: ',arg%nc_global
end if
- DEALLOCATE ( arg%ino, arg%flg, arg%par)
+ DEALLOCATE ( arg%ino, arg%flg)
DEALLOCATE ( arg%lon, arg%lat, arg%dpt, arg%tim)
DEALLOCATE ( arg%pb, arg%qb, arg%rb)
diff --git a/get_obs_sat.f90 b/get_obs_sat.f90
index 250730d..d280cbd 100644
--- a/get_obs_sat.f90
+++ b/get_obs_sat.f90
@@ -2,16 +2,17 @@ subroutine get_obs_sat
!---------------------------------------------------------------------------
! !
- ! Copyright 2006 Srdjan Dobricic, CMCC, Bologna !
+ ! Copyright 2018 Anna Teruzzi, OGS, Trieste !
! !
- ! This file is part of OceanVar. !
+ ! This file is part of 3DVarBio.
+ ! 3DVarBio is based on OceanVar (Dobricic, 2006) !
! !
- ! OceanVar is free software: you can redistribute it and/or modify. !
+ ! 3DVarBio 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, !
+ ! 3DVarBio 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. !
@@ -22,8 +23,9 @@ subroutine get_obs_sat
!---------------------------------------------------------------------------
!-----------------------------------------------------------------------
- ! !
- ! Load Chlorophyll observations !
+ ! Version 1: A. Teruzzi 2018 !
+ !
+ ! Load Chlorophyll observations !
! !
!-----------------------------------------------------------------------
@@ -33,6 +35,7 @@ subroutine get_obs_sat
use obs_str
use mpi_str
use pnetcdf
+ use da_params
use filenames
implicit none
@@ -41,13 +44,29 @@ subroutine get_obs_sat
INTEGER(i4) :: i
REAL(r8) :: zbo, zbn
REAL(r4), ALLOCATABLE :: chl_mis(:,:),chl_err(:,:)
- INTEGER(i4) :: stat, ncid, idvar, VarId
+ REAL(i4), ALLOCATABLE :: flagblk(:,:)
+ INTEGER(i4) :: stat, ncid, idvar, VarId, ierr
+ INTEGER(i4) :: xid, yid, idF, ii
+ INTEGER(KIND=MPI_OFFSET_KIND) :: global_im, global_jm
+ INTEGER(KIND=MPI_OFFSET_KIND) :: MyCountTwod(2), MyStartTwod(2)
+ CHARACTER(LEN=45) :: flagFile
+ CHARACTER(LEN=15) :: FlagVarName
+
+ global_im = GlobalRow
+ global_jm = GlobalCol
+ do ii=1,2
+ MyCountTwod(ii) = MyCount(ii)
+ MyStartTwod(ii) = MyStart(ii)
+ enddo
+
+
+
sat%no = 0
sat%nc = 0
stat = nf90mpi_open(Var3DCommunicator, trim(MISFIT_FILE), NF90_NOWRITE, MPI_INFO_NULL, ncid)
- if (stat .ne. NF90_NOERR ) call handle_err('nf90mpi_open', stat)
+ if (stat .ne. NF90_NOERR ) call handle_err('nf90mpi_open '//trim(MISFIT_FILE), stat)
if(stat.ne.0)then
sat%no = 0
@@ -76,6 +95,7 @@ subroutine get_obs_sat
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 ( flagblk(grd%im,grd%jm) )
ALLOCATE ( sat%flg(sat%no)) ; sat%flg = huge(sat%flg(1))
ALLOCATE ( sat%flc(sat%no)) ; sat%flc = huge(sat%flc(1))
ALLOCATE ( sat%inc(sat%no)) ; sat%inc = huge(sat%inc(1))
@@ -108,6 +128,7 @@ subroutine get_obs_sat
sat%res(k) = chl_mis(i,j)
sat%err(k) = chl_err(i,j)
enddo
+
! DECOMMENT FOLLOWING TWO LINES TO MAKE FILTER TEST
! sat%res(:) = 0.
@@ -123,6 +144,7 @@ subroutine get_obs_sat
! ---
! Initialise quality flag, do residual check, compute vertical integration parameters and count good observations
+ flagblk(:,:) = 0 !blacklisting flag
sat%nc = 0
do k=1,sat%no
j = (k-1)/grd%im + 1
@@ -132,6 +154,9 @@ subroutine get_obs_sat
if(abs(sat%res(k)).gt.sat%max_val) then
! residual check
sat%flg(k) = 0
+ if(abs(sat%res(k)).lt.100) then
+ flagblk(i,j) = 1
+ endif
else
! compute vertical integration parameters
zbn = grd%dep(1)*2.0
@@ -151,7 +176,40 @@ subroutine get_obs_sat
if(MyId .eq. 0) then
print*,'Good chl observations: ',sat%nc_global
+ print*,'Saving flag misfit'
endif
+
+ ! Saving flag misfit sat
+ flagFile = 'flagsat.'//ShortDate//'.nc'
+ ierr = nf90mpi_create(Var3DCommunicator, trim(flagFile), NF90_CLOBBER, MPI_INFO_NULL,ncid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('flagFile ', ierr)
+
+ ierr = nf90mpi_def_dim(ncid,'x',global_im ,xid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_dim longitude ', ierr)
+ ierr = nf90mpi_def_dim(ncid,'y' ,global_jm ,yid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_dim latitude ', ierr)
+
+ FlagVarName='flag_lim_misf'
+
+ ierr = nf90mpi_def_var(ncid, FlagVarName, nf90_int, (/xid,yid/), idF )
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_var', ierr)
+
+ ierr = nf90mpi_enddef(ncid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_enddef', ierr)
+
+
+ ierr = nf90mpi_put_var_all(ncid,idF,flagblk,MyStartTwod,MyCountTwod)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_put_var_all ', ierr)
+
+ ierr = nf90mpi_close(ncid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('LimCorrfile ', ierr)
+
+
+
+ DEALLOCATE ( flagblk )
+
+
+
sat%flc(:) = sat%flg(:)
end subroutine get_obs_sat
@@ -162,7 +220,7 @@ subroutine int_par_chl
! !
! Get interpolation parameters for a grid !
! !
- ! Version 1: S.Dobricic 2006 !
+ ! Version 1: A. Teruzzi 2018 !
!-----------------------------------------------------------------------
use set_knd
diff --git a/grd_str.f90 b/grd_str.f90
index d4f201d..c23b2b1 100644
--- a/grd_str.f90
+++ b/grd_str.f90
@@ -51,6 +51,11 @@ MODULE grd_str
REAL(r8), POINTER :: chl(:,:,:) ! chlorophyll
REAL(r8), POINTER :: chl_ad(:,:,:) ! chlorophyll adjoint variable
+ REAL(r8), POINTER :: n3n(:,:,:) ! n3n
+ REAL(r8), POINTER :: n3n_ad(:,:,:) ! n3n adjoint variable
+ REAL(r8), POINTER :: o2o(:,:,:) ! o2o
+ REAL(r8), POINTER :: o2o_ad(:,:,:) ! o2o adjoint variable
+
REAL(r8), POINTER :: dep(:) ! Depth
@@ -66,6 +71,8 @@ MODULE grd_str
INTEGER(i4) :: imax ! Maximum number of extended points
INTEGER(i4) :: jmax ! Maximum number of extended points
+ INTEGER(i4) :: imax_chl ! Maximum number of extended points until depth pf chl for multivariate
+ INTEGER(i4) :: jmax_chl ! Maximum number of extended points until depth of chl for multivariete
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
diff --git a/libnc-medlevel/Makefile b/libnc-medlevel/Makefile
deleted file mode 100644
index 6d94d08..0000000
--- a/libnc-medlevel/Makefile
+++ /dev/null
@@ -1,32 +0,0 @@
-
-include ../compiler.inc
-
-OBJS = nc-med-level-lib.o
-EXE =
-LIB = libnc-medlevel.a
-
-target: $(LIB)
-
-libnc-medlevel.a: $(OBJS)
- $(AR) cru $(LIB) $(OBJS)
-
-nc-med-level-lib.o: nc-med-level-lib.f90
- $(FC) $(FFLAGS) nc-med-level-lib.f90 -c
-
-
-
-clean:
- @rm -f $(OBJS)
-
-erase: clean
- @rm -f $(LIB)
-
-install: $(LIB)
- cp -p $(LIB) $(LIBDIR)
-
-uninstall: $(LIB)
- rm -f $(LIBDIR)/$(LIB)
-
-.SUFFIXES: .f90 .c .o
-.f90.o:
- $(FC) $(FFLAGS) $< -c
diff --git a/main.f90 b/main.f90
index 2b5747c..af4dded 100644
--- a/main.f90
+++ b/main.f90
@@ -15,6 +15,7 @@ program ocean_var
call oceanvar
! finalizing the MPI environment
+call clean_da_params
call mpi_stop
end program ocean_var
diff --git a/mpi_str.f90 b/mpi_str.f90
index f3a6adb..7858202 100644
--- a/mpi_str.f90
+++ b/mpi_str.f90
@@ -25,6 +25,10 @@ MODULE mpi_str
! GlobalColOffset : offset needed to read grd%global_msk
! MpiWinChl : Window for one-sided communication on grd%chl array
! MpiWinChlAd : Window for one-sided communication on grd%chl_ad array
+ ! MpiWinN3n : Window for one-sided communication on grd%n3n array
+ ! MpiWinN3nAd : Window for one-sided communication on grd%n3n_ad array
+ ! MpiWinO2o : Window for one-sided communication on grd%o2o array
+ ! MpiWinO2oAd : Window for one-sided communication on grd%o2o_ad array
! NextLocalRow : size of the local number of row for the process "below" MyID
!
! Var3DCommunicator : MPI Communicator (useful for the "interaction" with ogstm)
@@ -39,6 +43,8 @@ MODULE mpi_str
integer :: GlobalRowOffset, GlobalColOffset
integer :: MyPair
integer :: MpiWinChl, MpiWinChlAd
+ integer :: MpiWinN3n, MpiWinN3nAd
+ integer :: MpiWinO2o, MpiWinO2oAd
integer :: NextLocalRow
integer :: Var3DCommunicator
@@ -47,10 +53,142 @@ MODULE mpi_str
! Arrays needed for alltoallv communication
! X dimension
integer, allocatable, dimension(:) :: SendCountX2D, SendCountX3D, SendDisplX2D, SendDisplX3D
+ integer, allocatable, dimension(:) :: SendCountX3D_chl, SendDisplX3D_chl
integer, allocatable, dimension(:) :: RecCountX2D, RecCountX3D, RecDisplX2D, RecDisplX3D
+ integer, allocatable, dimension(:) :: RecCountX3D_chl, RecDisplX3D_chl
! Arrays needed for the ghost cells exchange
REAL(r8), POINTER, DIMENSION(:,:) :: ChlExtended
REAL(r8), POINTER, DIMENSION(:) :: SendTop, RecBottom, SendBottom, RecTop
+ REAL(r8), ALLOCATABLE, DIMENSION(:,:) :: SendTop_2d, RecBottom_2d
+ REAL(r8), ALLOCATABLE, DIMENSION(:,:) :: SendBottom_2d, RecTop_2d
+ REAL(r8), ALLOCATABLE, DIMENSION(:,:,:) :: ChlExtended_3d, N3nExtended_3d, O2oExtended_3d
+
+
+CONTAINS
+
+ SUBROUTINE EXTEND_2D(INPUT, my_km, OUTPUT_Extended)
+ use set_knd
+ use grd_str
+ use obs_str
+ use drv_str
+ use bio_str
+ IMPLICIT NONE
+ INTEGER(i4) :: my_km
+ REAL(r8), DIMENSION(grd%im , grd%jm , my_km), INTENT(IN) :: INPUT
+ REAL(r8), DIMENSION(grd%im+1, grd%jm , my_km), INTENT(OUT) :: OUTPUT_Extended
+
+
+ INTEGER(i4) :: i, j, k, kk
+ INTEGER :: MyTag
+ INTEGER :: ReqTop, ReqBottom, ierr
+ INTEGER :: StatBottom(MPI_STATUS_SIZE)
+
+
+ ! Filling array to send
+ do k=1,my_km
+ do j=1,grd%jm
+ SendTop_2d(j,k) = INPUT(1,j,k)
+ end do
+ end do
+
+ do k=my_km+1,grd%km
+ SendTop_2d(:,k) = 0
+ end do
+
+ MyTag = 42
+ RecBottom_2d(:,:) = 0
+
+ call MPI_Isend(SendTop_2d, grd%jm*grd%km, MPI_REAL8, ProcTop, MyTag, &
+ Var3DCommunicator, ReqTop, ierr)
+ call MPI_Irecv(RecBottom_2d, grd%jm*grd%km, MPI_REAL8, ProcBottom, MyTag, &
+ Var3DCommunicator, ReqBottom, ierr)
+
+ do k=1,my_km
+ do j=1,grd%jm
+ do i=1,grd%im
+ OUTPUT_Extended(i,j,k) = INPUT(i,j,k)
+ end do
+ end do
+ end do
+
+
+ call MPI_Wait(ReqBottom, StatBottom, ierr)
+ do k=1,my_km
+ do j=1,grd%jm
+ OUTPUT_Extended(grd%im+1,j,k) = RecBottom_2d(j,k)
+ end do
+ end do
+
+
+
+ END SUBROUTINE EXTEND_2D
+
+
+ SUBROUTINE ADD_PREVCORE_CONTRIB(INPUT_Extended,my_km,OUTPUT,INIT_2d)
+ ! ADDS PREVIOUS CORE CONTRIBUTION to the sum of an _ad variable
+ ! used in obs_arg_ad
+ !
+ ! THEORY
+
+ ! OUTPUT = INIT + contr(i) + contr(i+1)
+ ! but without ghost cell we have
+ ! OUTPUT(1) = INIT + contr(1)
+ ! OUTPUT(im+1) = INIT + contr(im+1)
+ ! i.e one single contribution
+
+ ! im+1 is position 1 of following core,
+ ! then we can receive contr(im+1) in RecTop_2d
+
+ ! In order to have OUTPUT = INIT + contr(i) + contr(i+1) we'll do
+ ! OUTPUT(1) = INIT + contrib(1) + INIT + contr(i+1) - INIT
+ ! OUTPUT(1) + Rec_top - INIT
+
+ use set_knd
+ use grd_str
+ use obs_str
+ use drv_str
+ use bio_str
+ IMPLICIT NONE
+ INTEGER(i4) :: my_km
+ REAL(r8), DIMENSION(grd%im+1, grd%jm , my_km), INTENT(IN) :: INPUT_Extended
+ REAL(r8), DIMENSION(grd%im , grd%jm , my_km), INTENT(OUT) :: OUTPUT
+ REAL(r8), DIMENSION( grd%jm , my_km), INTENT(IN) :: INIT_2d
+
+ INTEGER :: ReqBottom, ReqTop, ierr
+ INTEGER(i4) :: i, j, k, kk
+ INTEGER :: MyTag
+ INTEGER :: StatTop(MPI_STATUS_SIZE)
+
+ do k=1,my_km
+ do j=1,grd%jm
+ SendBottom_2d(j,k) = INPUT_Extended(grd%im+1,j,k)
+ end do
+ end do
+
+
+ do k=my_km+1,grd%km
+ SendBottom_2d(:,k) = 0
+ end do
+
+ MyTag = 42
+ RecTop_2d(:,:) = 0
+
+ call MPI_Isend(SendBottom_2d, grd%jm*grd%km, MPI_REAL8, ProcBottom, MyTag, &
+ Var3DCommunicator, ReqBottom, ierr)
+ call MPI_Irecv(RecTop_2d, grd%jm*grd%km, MPI_REAL8, ProcTop, MyTag, &
+ Var3DCommunicator, ReqTop, ierr)
+
+ OUTPUT = INPUT_Extended(1:grd%im,:,:)
+
+ call MPI_Wait(ReqTop, StatTop, ierr)
+
+ do k=1,my_km
+ do j=1,grd%jm
+ OUTPUT(1,j,k) = OUTPUT(1,j,k) + RecTop_2d(j,k) - INIT_2d(j,k)
+ end do
+ end do
+
+ END SUBROUTINE ADD_PREVCORE_CONTRIB
END MODULE mpi_str
diff --git a/mpi_utils.f90 b/mpi_utils.f90
index 17ff534..443c9f0 100644
--- a/mpi_utils.f90
+++ b/mpi_utils.f90
@@ -1,6 +1,12 @@
subroutine var3d_mpi_init()
+#include
+#if PETSC_VERSION_GE(3,8,0)
+#include "petsc/finclude/petscvec.h"
+#else
#include "petsc/finclude/petscvecdef.h"
+#endif
+
use mpi_str
use drv_str
use petscvec
@@ -93,9 +99,13 @@ subroutine my_3dvar_node()
call MPI_TYPE_COMMIT(MyPair, ierr)
ALLOCATE(SendCountX2D(NumProcI), SendCountX3D(NumProcI))
+ ALLOCATE(SendCountX3D_chl(NumProcI))
ALLOCATE(SendDisplX2D(NumProcI), SendDisplX3D(NumProcI))
+ ALLOCATE(SendDisplX3D_chl(NumProcI))
ALLOCATE(RecCountX2D(NumProcI), RecCountX3D(NumProcI))
+ ALLOCATE(RecCountX3D_chl(NumProcI))
ALLOCATE(RecDisplX2D(NumProcI), RecDisplX3D(NumProcI))
+ ALLOCATE(RecDisplX3D_chl(NumProcI))
! print for debug
! write(*,*) "MyId", MyId, "PosI", MyPosI, "PosJ", MyPosJ, "Left", ProcLeft, "Right", ProcRight, "Top", ProcTop, "Bottom", ProcBottom
@@ -136,7 +146,13 @@ end subroutine mpi_sync
subroutine mpi_stop
+#include
+#if PETSC_VERSION_GE(3,8,0)
+#include "petsc/finclude/petscvec.h"
+#else
#include "petsc/finclude/petscvecdef.h"
+#endif
+
use mpi_str
use petscvec
diff --git a/namelists/satfloat.20150101.nml b/namelists/satfloat.20150101.nml
new file mode 100644
index 0000000..5fbd536
--- /dev/null
+++ b/namelists/satfloat.20150101.nml
@@ -0,0 +1,59 @@
+!------------------------------------------------------------
+! OceanVar namelist specification for multivariate and multiplatform
+!------------------------------------------------------------
+!------------------------------------------------------------
+!
+! Namelist biolst
+! ---
+!
+! Biological assimilation set-up
+!
+! chl_assim - Chlorophyll assimilation
+! chl_upnut - Nutrient update based on chl assimilation chl_upnut
+! nut - Nutrient assimilation
+! multiv - Multivariate assimilation
+! nphyto - Number of phytoplankton species
+! chl_dep - Minimum depth for chlorophyll
+! ncmp - Number of phytoplankton components
+! ApplyConditions - Apply conditions flag
+! N3n - N3n assimilation
+! updateN1p - N1p update based on N3n assimilation updateN1p
+! O2o - O2o assimilation
+!
+! ---
+&biolst
+ chl_assim = 1
+ chl_upnut = 0
+ nut = 1
+ nphyto = 4
+ chl_dep = 0.0
+ ncmp = 5
+ApplyConditions = .true.
+ N3n = 1
+ updateN1p = 0
+ O2o = 1
+/
+!------------------------------------------------------------
+!
+! Namelist parameters
+! ---
+!
+! Parameters namelist
+!
+! sat - 1-assimilate satellite data
+! 0-no satellite assimilation
+! argo - 1-assimilate argo data
+! - 0-no argo assimilation
+! uniformL - 1-non uniform radius
+! - 0-uniform radius (rcf%L)
+! anisL - 1-anisotropy
+! 0-isotropy
+!
+! ---
+¶ms
+ sat_obs = 1
+ argo = 1
+ uniformL = 0
+ anisL = 0
+/
+!------------------------------------------------------------
diff --git a/namelists/var_3d_nml b/namelists/var_3d_nml
index d3b39c4..a2cbc7d 100644
--- a/namelists/var_3d_nml
+++ b/namelists/var_3d_nml
@@ -8,14 +8,15 @@
!
! BFGS minimizers set-up
!
-! ctl_m - Number of copies saved in the minimizer
-! ctl_tol - Stopping criteria (absolute)
-! ctl_per - Stopping criteria (relative)
+! ctl_tol - Minimum gradient of J
+! ctl_per - Percentage of initial gradient
+! verbose - Add verbose on standard output
!
! ---
&ctllst
ctl_tol = 1.e-11
ctl_per = 1.e-3
+ verbose = 1
/
!------------------------------------------------------------
!
@@ -24,8 +25,13 @@
!
! Covariance constants
!
-! neof - Number of vertical EOFs
-! nreg - Number of regions
+! neof_chl - Number of vertical EOFs for chl
+! neof_n3n - Number of vertical EOFs for n3n
+! neof_o2o - Number of vertical EOFs for o2o
+! neof_multi - Number of multivariate vertical EOFs
+! kmchl - chl Nlevels in multi EOFs
+! kmnit - nit Nlevels in multi EOFs
+! nreg - Number of regions
! read_eof - Logical to read EOFs from files.
! See subroutine def_cov.f90
! rcf_ntr - Number of iterations of the recursive filter
@@ -34,59 +40,16 @@
!
! ---
&covlst
- neof = 4
- nreg = 63045
+ neof_chl = 4
+ neof_n3n = 4
+ neof_o2o = 4
+ neof_multi = 26
+ kmchl = 26
+ kmnit = 40
+ nreg = 15
read_eof = .true.
rcf_ntr = 4
rcf_L = 5000.
rcf_efc = 5.0
/
!------------------------------------------------------------
-!
-! Namelist biolst
-! ---
-!
-! Biological assimilation set-up
-!
-! biol - 1-biological variables in state vector,
-! 0-no biological variables in state vector
-! bphy - 1-biological and physical variables in state vector,
-! 0-no physical variables in state vector
-! nchl - Number of phytoplankton species
-! chl_dep - Minimum depth for chlorophyll assimilation
-! lsize - size of the working block in the master-slave approach
-!
-! ---
-&biolst
- bio_assim = 1
- nphyto = 4
- chl_dep = 0.0
- ncmp = 5
-ApplyConditions = .true.
-/
-!------------------------------------------------------------
-!
-! Namelist parameters
-! ---
-!
-! Parameters namelist
-!
-! sat - 1-assimilate satellite data
-! 0-no satellite assimilation
-! argo - 1-assimilate argo data
-! - 0-no argo assimilation
-! uniformL - 1-non uniform radius
-! - 0-uniform radius (rcf%L)
-! anisL - 1-anisotropy
-! 0-isotropy
-! verbose - 1-set verbose output
-!
-! ---
-¶ms
- sat_obs = 1
- argo = 0
- uniformL = 0
- anisL = 0
- verbose = 1
-/
-!------------------------------------------------------------
diff --git a/libnc-medlevel/nc-med-level-lib.f90 b/nc-med-level-lib.f90
similarity index 100%
rename from libnc-medlevel/nc-med-level-lib.f90
rename to nc-med-level-lib.f90
diff --git a/netcdf_err.f90 b/netcdf_err.f90
index a457fc2..893e5bf 100644
--- a/netcdf_err.f90
+++ b/netcdf_err.f90
@@ -27,7 +27,7 @@ subroutine netcdf_err(errcode)
implicit none
- INTEGER(i4), intent(in) :: errcode
+ INTEGER(i4) :: errcode
if(errcode /= nf90_noerr) then
print*,'Netcdf Error: ', trim(nf90_strerror(errcode))
diff --git a/obs_arg.f90 b/obs_arg.f90
index 3071d62..39d95f8 100644
--- a/obs_arg.f90
+++ b/obs_arg.f90
@@ -5,7 +5,7 @@ subroutine obs_arg
! !
! Copyright 2006 Srdjan Dobricic, CMCC, Bologna !
! !
- ! This file is part of OceanVar. !
+ ! 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 !
@@ -18,7 +18,7 @@ subroutine obs_arg
! 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 . !
+ ! along with OceanVar. If not, see . !
! !
!---------------------------------------------------------------------------
@@ -32,59 +32,86 @@ subroutine obs_arg
use set_knd
use grd_str
+ use eof_str
use obs_str
use mpi_str
+ use drv_str
+ use bio_str
implicit none
+
+ INTEGER(i4) :: i, j, k, kk, condc, condn, my_km
- INTEGER(i4) :: i, j, k, kk
- REAL(r8) :: FirstData, SecData, ThirdData, LastData, Test
- INTEGER(kind=MPI_ADDRESS_KIND) :: TargetOffset
- INTEGER :: ierr, NData
- real(r8), pointer, dimension(:,:,:) :: GetData
-
+ my_km = grd%km
+ if(drv%multiv.eq.1) &
+ my_km = ros%kmchl
+
+ condc = 0
+ condn = 0
+ if ((drv%chl_assim.eq.1 ) .or. (drv%multiv.eq.1)) then
+ condc = 1
+ call EXTEND_2D( grd%chl, my_km, ChlExtended_3d )
+ endif
+ if ((drv%nut.eq.1 .and. bio%N3n.eq.1 ) .or. (drv%multiv.eq.1)) then
+ condn = 1
+ call EXTEND_2D( grd%n3n, grd%km, N3nExtended_3d )
+ endif
+ if (bio%O2o.eq.1 ) &
+ call EXTEND_2D( grd%O2o, grd%km, O2oExtended_3d )
+
+
+
do kk = 1,arg%no
-
- if(arg%flc(kk).eq.1)then
-
- i=arg%ib(kk)
- j=arg%jb(kk)
- k=arg%kb(kk)
-
- if(i .lt. grd%im) then
- arg%inc(kk) = arg%pq1(kk) * grd%chl(i ,j ,k) + &
- arg%pq2(kk) * grd%chl(i+1,j ,k ) + &
- arg%pq3(kk) * grd%chl(i ,j+1,k ) + &
- arg%pq4(kk) * grd%chl(i+1,j+1,k ) + &
- arg%pq5(kk) * grd%chl(i ,j ,k+1) + &
- arg%pq6(kk) * grd%chl(i+1,j ,k+1) + &
- arg%pq7(kk) * grd%chl(i ,j+1,k+1) + &
- arg%pq8(kk) * grd%chl(i+1,j+1,k+1)
-
- else
- ALLOCATE(GetData(NextLocalRow,grd%jm,2))
-
- NData = NextLocalRow*grd%jm*2
- call MPI_Win_lock (MPI_LOCK_EXCLUSIVE, ProcBottom, 0, MpiWinChl, ierr )
- TargetOffset = (k-1)*grd%jm*NextLocalRow
- call MPI_Get (GetData, NData, MPI_REAL8, ProcBottom, TargetOffset, NData, MPI_REAL8, MpiWinChl, ierr)
- call MPI_Win_unlock(ProcBottom, MpiWinChl, ierr)
-
- arg%inc(kk) = arg%pq1(kk) * grd%chl(i ,j ,k) + &
- arg%pq2(kk) * GetData(1 ,j ,1 ) + &
- arg%pq3(kk) * grd%chl(i ,j+1,k ) + &
- arg%pq4(kk) * GetData(1 ,j+1,1 ) + &
- arg%pq5(kk) * grd%chl(i ,j ,k+1) + &
- arg%pq6(kk) * GetData(1 ,j ,2 ) + &
- arg%pq7(kk) * grd%chl(i ,j+1,k+1) + &
- arg%pq8(kk) * GetData(1 ,j+1,2 )
-
-
- DEALLOCATE(GetData)
- endif
-
+
+ i=arg%ib(kk)
+ j=arg%jb(kk)
+ k=arg%kb(kk)
+
+ if(arg%flc(kk).eq.1 .and. arg%par(kk).eq.0 .and. condc.eq.1) then
+
+ arg%inc(kk) = &
+ arg%pq1(kk) * ChlExtended_3d(i ,j ,k) + &
+ arg%pq2(kk) * ChlExtended_3d(i+1,j ,k ) + &
+ arg%pq3(kk) * ChlExtended_3d(i ,j+1,k ) + &
+ arg%pq4(kk) * ChlExtended_3d(i+1,j+1,k ) + &
+ arg%pq5(kk) * ChlExtended_3d(i ,j ,k+1) + &
+ arg%pq6(kk) * ChlExtended_3d(i+1,j ,k+1) + &
+ arg%pq7(kk) * ChlExtended_3d(i ,j+1,k+1) + &
+ arg%pq8(kk) * ChlExtended_3d(i+1,j+1,k+1)
+ ! if(drv%multiv .eq. 1) &
+ ! arg%inc(kk) = arg%inc(kk) * arg%std(kk)
+ endif
+ if(arg%flc(kk).eq.1 .and. arg%par(kk).eq.1 .and. condn.eq.1) then
+
+
+ arg%inc(kk) = &
+ arg%pq1(kk) * N3nExtended_3d(i ,j ,k) + &
+ arg%pq2(kk) * N3nExtended_3d(i+1,j ,k ) + &
+ arg%pq3(kk) * N3nExtended_3d(i ,j+1,k ) + &
+ arg%pq4(kk) * N3nExtended_3d(i+1,j+1,k ) + &
+ arg%pq5(kk) * N3nExtended_3d(i ,j ,k+1) + &
+ arg%pq6(kk) * N3nExtended_3d(i+1,j ,k+1) + &
+ arg%pq7(kk) * N3nExtended_3d(i ,j+1,k+1) + &
+ arg%pq8(kk) * N3nExtended_3d(i+1,j+1,k+1)
+ ! if(drv%multiv .eq. 1) &
+ ! arg%inc(kk) = arg%inc(kk) * arg%std(kk)
+ endif
+ if(arg%flc(kk).eq.1 .and. arg%par(kk).eq.2 .and. drv%nut.eq.1 .and. bio%o2o.eq.1) then
+
+ arg%inc(kk) = &
+ arg%pq1(kk) * O2oExtended_3d(i ,j ,k) + &
+ arg%pq2(kk) * O2oExtended_3d(i+1,j ,k ) + &
+ arg%pq3(kk) * O2oExtended_3d(i ,j+1,k ) + &
+ arg%pq4(kk) * O2oExtended_3d(i+1,j+1,k ) + &
+ arg%pq5(kk) * O2oExtended_3d(i ,j ,k+1) + &
+ arg%pq6(kk) * O2oExtended_3d(i+1,j ,k+1) + &
+ arg%pq7(kk) * O2oExtended_3d(i ,j+1,k+1) + &
+ arg%pq8(kk) * O2oExtended_3d(i+1,j+1,k+1)
+
endif
-
+
+
enddo
+
end subroutine obs_arg
diff --git a/obs_arg_ad.f90 b/obs_arg_ad.f90
index a1c0347..db4b78d 100644
--- a/obs_arg_ad.f90
+++ b/obs_arg_ad.f90
@@ -5,7 +5,7 @@ subroutine obs_arg_ad
! !
! Copyright 2006 Srdjan Dobricic, CMCC, Bologna !
! !
- ! This file is part of OceanVar. !
+ ! 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 !
@@ -18,7 +18,7 @@ subroutine obs_arg_ad
! 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 . !
+ ! along with OceanVar. If not, see . !
! !
!---------------------------------------------------------------------------
@@ -32,67 +32,116 @@ subroutine obs_arg_ad
use set_knd
use grd_str
+ use eof_str
use obs_str
use mpi_str
use filenames
use drv_str
+ use bio_str
implicit none
- INTEGER(i4) :: i, j, k, kk
- REAL(r8) :: ToSum
- INTEGER(kind=MPI_ADDRESS_KIND) :: TargetOffset
- INTEGER :: ierr, NData
- real(r8), pointer, dimension(:,:,:) :: MatrixToSum
+ INTEGER(i4) :: i, j, k, kk, condc, condn, my_km
+ REAL(r8), DIMENSION(grd%jm,grd%km) :: slicevar
+ REAL(8) :: obsg
+
+ my_km = grd%km
+ if(drv%multiv.eq.1) &
+ my_km = ros%kmchl
+ condc = 0
+ condn = 0
+ if ((drv%chl_assim.eq.1 ) .or. (drv%multiv.eq.1)) then
+ condc = 1
+ call EXTEND_2D( grd%chl_ad, my_km, ChlExtended_3d )
+ endif
+ if ((drv%nut.eq.1 .and. bio%N3n.eq.1 ) .or. (drv%multiv.eq.1)) then
+ call EXTEND_2D( grd%n3n_ad, grd%km, N3nExtended_3d )
+ condn = 1
+ endif
+ if (drv%nut.eq.1 .and. bio%O2o.eq.1 ) &
+ call EXTEND_2D( grd%O2o_ad, grd%km, O2oExtended_3d )
+
+
do kk = 1,arg%no
-
- if(arg%flc(kk).eq.1)then
-
- obs%k = obs%k + 1
-
- i=arg%ib(kk)
- j=arg%jb(kk)
- k=arg%kb(kk)
-
- if(i .lt. grd%im) then
-
- grd%chl_ad(i ,j ,k ) = grd%chl_ad(i ,j ,k ) + arg%pq1(kk) * obs%gra(obs%k)
- grd%chl_ad(i+1,j ,k ) = grd%chl_ad(i+1,j ,k ) + arg%pq2(kk) * obs%gra(obs%k)
- grd%chl_ad(i ,j+1,k ) = grd%chl_ad(i ,j+1,k ) + arg%pq3(kk) * obs%gra(obs%k)
- grd%chl_ad(i+1,j+1,k ) = grd%chl_ad(i+1,j+1,k ) + arg%pq4(kk) * obs%gra(obs%k)
- grd%chl_ad(i ,j ,k+1) = grd%chl_ad(i ,j ,k+1) + arg%pq5(kk) * obs%gra(obs%k)
- grd%chl_ad(i+1,j ,k+1) = grd%chl_ad(i+1,j ,k+1) + arg%pq6(kk) * obs%gra(obs%k)
- grd%chl_ad(i ,j+1,k+1) = grd%chl_ad(i ,j+1,k+1) + arg%pq7(kk) * obs%gra(obs%k)
- grd%chl_ad(i+1,j+1,k+1) = grd%chl_ad(i+1,j+1,k+1) + arg%pq8(kk) * obs%gra(obs%k)
-
- else
-
- ALLOCATE(MatrixToSum(NextLocalRow,grd%jm,2))
- MatrixToSum(:,:,:) = dble(0)
-
- grd%chl_ad(i ,j ,k ) = grd%chl_ad(i ,j ,k ) + arg%pq1(kk) * obs%gra(obs%k)
- grd%chl_ad(i ,j+1,k ) = grd%chl_ad(i ,j+1,k ) + arg%pq3(kk) * obs%gra(obs%k)
- grd%chl_ad(i ,j ,k+1) = grd%chl_ad(i ,j ,k+1) + arg%pq5(kk) * obs%gra(obs%k)
- grd%chl_ad(i ,j+1,k+1) = grd%chl_ad(i ,j+1,k+1) + arg%pq7(kk) * obs%gra(obs%k)
-
- MatrixToSum(1,j ,1) = arg%pq2(kk) * obs%gra(obs%k)
- MatrixToSum(1,j+1,1) = arg%pq4(kk) * obs%gra(obs%k)
- MatrixToSum(1,j ,2) = arg%pq6(kk) * obs%gra(obs%k)
- MatrixToSum(1,j+1,2) = arg%pq8(kk) * obs%gra(obs%k)
-
- call MPI_Win_lock (MPI_LOCK_EXCLUSIVE, ProcBottom, 0, MpiWinChlAd, ierr )
- NData = NextLocalRow*grd%jm*2
- TargetOffset = (k-1)*grd%jm*NextLocalRow
- call MPI_Accumulate (MatrixToSum, NData, MPI_REAL8, ProcBottom, TargetOffset, NData, MPI_REAL8, MPI_SUM, MpiWinChlAd, ierr)
-
- call MPI_Win_unlock(ProcBottom, MpiWinChlAd, ierr)
- DEALLOCATE(MatrixToSum)
-
- endif
-
- endif
-
+
+ i=arg%ib(kk)
+ j=arg%jb(kk)
+ k=arg%kb(kk)
+
+ if(arg%flc(kk).eq.1 .and. arg%par(kk).eq.0 .and. condc.eq.1)then
+
+ obs%k = obs%k + 1
+ ! if(drv%multiv .eq. 1) then
+ ! obsg = obs%gra(obs%k)*arg%std(kk)
+ ! else
+ obsg = obs%gra(obs%k)
+ ! end if
+
+ ChlExtended_3d(i ,j ,k ) = ChlExtended_3d(i ,j ,k ) + arg%pq1(kk) * obsg
+ ChlExtended_3d(i+1,j ,k ) = ChlExtended_3d(i+1,j ,k ) + arg%pq2(kk) * obsg
+ ChlExtended_3d(i ,j+1,k ) = ChlExtended_3d(i ,j+1,k ) + arg%pq3(kk) * obsg
+ ChlExtended_3d(i+1,j+1,k ) = ChlExtended_3d(i+1,j+1,k ) + arg%pq4(kk) * obsg
+ ChlExtended_3d(i ,j ,k+1) = ChlExtended_3d(i ,j ,k+1) + arg%pq5(kk) * obsg
+ ChlExtended_3d(i+1,j ,k+1) = ChlExtended_3d(i+1,j ,k+1) + arg%pq6(kk) * obsg
+ ChlExtended_3d(i ,j+1,k+1) = ChlExtended_3d(i ,j+1,k+1) + arg%pq7(kk) * obsg
+ ChlExtended_3d(i+1,j+1,k+1) = ChlExtended_3d(i+1,j+1,k+1) + arg%pq8(kk) * obsg
+ endif
+ if(arg%flc(kk).eq.1 .and. arg%par(kk).eq.1 .and. condn.eq.1) then
+
+ obs%k = obs%k + 1
+ ! if(drv%multiv .eq. 1) then
+ ! obsg = obs%gra(obs%k)*arg%std(kk)
+ ! else
+ obsg = obs%gra(obs%k)
+ ! end if
+
+ N3nExtended_3d(i ,j ,k ) = N3nExtended_3d(i ,j ,k ) + arg%pq1(kk) * obsg
+ N3nExtended_3d(i+1,j ,k ) = N3nExtended_3d(i+1,j ,k ) + arg%pq2(kk) * obsg
+ N3nExtended_3d(i ,j+1,k ) = N3nExtended_3d(i ,j+1,k ) + arg%pq3(kk) * obsg
+ N3nExtended_3d(i+1,j+1,k ) = N3nExtended_3d(i+1,j+1,k ) + arg%pq4(kk) * obsg
+ N3nExtended_3d(i ,j ,k+1) = N3nExtended_3d(i ,j ,k+1) + arg%pq5(kk) * obsg
+ N3nExtended_3d(i+1,j ,k+1) = N3nExtended_3d(i+1,j ,k+1) + arg%pq6(kk) * obsg
+ N3nExtended_3d(i ,j+1,k+1) = N3nExtended_3d(i ,j+1,k+1) + arg%pq7(kk) * obsg
+ N3nExtended_3d(i+1,j+1,k+1) = N3nExtended_3d(i+1,j+1,k+1) + arg%pq8(kk) * obsg
+
+
+ endif
+ if(arg%flc(kk).eq.1 .and. arg%par(kk).eq.2 .and. drv%nut.eq.1 .and. bio%o2o.eq.1) then
+
+ obs%k = obs%k + 1
+
+ O2oExtended_3d(i ,j ,k ) = O2oExtended_3d(i ,j ,k ) + arg%pq1(kk) * obs%gra(obs%k)
+ O2oExtended_3d(i+1,j ,k ) = O2oExtended_3d(i+1,j ,k ) + arg%pq2(kk) * obs%gra(obs%k)
+ O2oExtended_3d(i ,j+1,k ) = O2oExtended_3d(i ,j+1,k ) + arg%pq3(kk) * obs%gra(obs%k)
+ O2oExtended_3d(i+1,j+1,k ) = O2oExtended_3d(i+1,j+1,k ) + arg%pq4(kk) * obs%gra(obs%k)
+ O2oExtended_3d(i ,j ,k+1) = O2oExtended_3d(i ,j ,k+1) + arg%pq5(kk) * obs%gra(obs%k)
+ O2oExtended_3d(i+1,j ,k+1) = O2oExtended_3d(i+1,j ,k+1) + arg%pq6(kk) * obs%gra(obs%k)
+ O2oExtended_3d(i ,j+1,k+1) = O2oExtended_3d(i ,j+1,k+1) + arg%pq7(kk) * obs%gra(obs%k)
+ O2oExtended_3d(i+1,j+1,k+1) = O2oExtended_3d(i+1,j+1,k+1) + arg%pq8(kk) * obs%gra(obs%k)
+
+ endif
+
enddo
-
+
+! we apply contribution in grd%variable_ad
+
+ if((drv%chl_assim.eq.1) .or. (drv%multiv.eq.1)) then
+ slicevar(:,1:my_km) = grd%chl_ad(1,:,1:my_km)
+ call ADD_PREVCORE_CONTRIB(ChlExtended_3d, my_km, grd%chl_ad, slicevar(:,1:my_km))
+ ! call ADD_PREVCORE_CONTRIB(ChlExtended_3d, my_km, grd%chl_ad, grd%chl_ad(1,:,:))
+ endif
+ if((bio%N3n.eq.1) .or. (drv%multiv.eq.1)) then
+ slicevar(:,1:grd%km) = grd%n3n_ad(1,:,:)
+ call ADD_PREVCORE_CONTRIB(N3nExtended_3d, grd%km, grd%n3n_ad, slicevar)
+ ! call ADD_PREVCORE_CONTRIB(N3nExtended_3d, grd%km, grd%N3n_ad, grd%n3n_ad(1,:,:))
+ endif
+ if (bio%O2o.eq.1 ) then
+ slicevar(:,1:grd%km) = grd%o2o_ad(1,:,:)
+ call ADD_PREVCORE_CONTRIB(O2oExtended_3d, grd%km, grd%o2o_ad, slicevar)
+ ! call ADD_PREVCORE_CONTRIB(O2oExtended_3d, grd%km, grd%O2o_ad, grd%o2o_ad(1,:,:))
+ endif
+
+
+
end subroutine obs_arg_ad
diff --git a/obs_str.f90 b/obs_str.f90
index e00aca9..9d5eee7 100644
--- a/obs_str.f90
+++ b/obs_str.f90
@@ -59,7 +59,7 @@ MODULE obs_str
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 :: par(:) ! Parameter flag (0-chl, 1-N3n, 2-O2o)
INTEGER(i8), POINTER :: flg(:) ! Quality flag
INTEGER(i8), POINTER :: flc(:) ! Temporary flag for multigrid
REAL(r8), POINTER :: lon(:) ! Longitute
@@ -68,6 +68,7 @@ MODULE obs_str
REAL(r8), POINTER :: tim(:) ! Time
REAL(r8), POINTER :: inc(:) ! Increments
REAL(r8), POINTER :: err(:) ! Observational error
+ ! REAL(r8), POINTER :: std(:) ! STD used for EOFs normalization
REAL(r8), POINTER :: res(:) ! residual
INTEGER(i8), POINTER :: ib(:) ! i index of the nearest west point
REAL(r8) , POINTER :: pb(:) ! distance from the nearest west point
diff --git a/obs_vec.f90 b/obs_vec.f90
index 1ca2966..dd9d7fb 100644
--- a/obs_vec.f90
+++ b/obs_vec.f90
@@ -42,7 +42,7 @@ subroutine obs_vec
! -------
! Define observational vector
- obs%no = sat%nc + arg%no
+ obs%no = sat%nc + arg%nc
if(MyId .eq. 0) &
write(drv%dia,*) ' Total number of observations: ', obs%no
@@ -70,7 +70,7 @@ subroutine obs_vec
endif
- ! Observations of chlorophyll
+ ! Observations of satellite chlorophyll
if(drv%sat_obs .eq. 1) then
do i=1,sat%no
if(sat%flc(i).eq.1)then
diff --git a/obsop.f90 b/obsop.f90
index d3e112b..466e1f1 100644
--- a/obsop.f90
+++ b/obsop.f90
@@ -42,7 +42,7 @@ subroutine obsop
! ---
! Apply biological repartition of the chlorophyll
- if(drv%bio_assim .eq. 1) &
+ if((drv%chl_assim .eq. 1) .or. (drv%multiv .eq. 1)) &
call bio_conv
! ---
diff --git a/obsop_ad.f90 b/obsop_ad.f90
index 44b6969..cc90231 100644
--- a/obsop_ad.f90
+++ b/obsop_ad.f90
@@ -52,7 +52,7 @@ subroutine obsop_ad
! ---
! Apply biological repartition of the chlorophyll
- if(drv%bio_assim .eq. 1) &
+ if((drv%chl_assim .eq. 1) .or. (drv%multiv .eq. 1)) &
call bio_conv_ad
call MPI_Barrier(Var3DCommunicator, ierr)
diff --git a/oceanvar.f90 b/oceanvar.f90
index f515408..2185806 100644
--- a/oceanvar.f90
+++ b/oceanvar.f90
@@ -38,6 +38,8 @@ subroutine oceanvar
use set_knd
use drv_str
use mpi_str
+ use da_params
+ use bio_str
implicit none
@@ -47,7 +49,8 @@ subroutine oceanvar
! ---
! Initialize diagnostics and read namelists
- call def_nml
+ call def_nml ! General DA parameters
+ call def_nml_multi ! DA parameters for multivariate and multiplatform
! ---
! Define grid parameters
@@ -96,12 +99,42 @@ subroutine oceanvar
! ---
! Convert to innovations
call cnv_inn
+
! ---
- ! Write outputs and diagnostics
- if(drv%bio_assim .eq. 0) then
- call wrt_dia
- else
- call wrt_bio_stat
+ ! Write corr.nc
+ call wrt_dia
+
+ ! Write restarts for chl and related variables
+ if((drv%chl_assim .eq. 1) .or. (drv%multiv .eq. 1)) then
+ call wrt_chl_stat
+
+ ! To write a copy of RSTbefore in RST_after
+ ! In case of assimiation of chl only at some dates
+ if ((drv%nut.eq.0) .and. (NNutVar.gt.0) .and. (drv%multiv.eq.0)) then
+ call cp_o2o_stat
+ if (drv%chl_upnut .eq. 1) then
+ call wrt_upd_nut
+ else
+ call cp_nut_stat
+ endif
+ endif
+ endif
+
+ if(drv%chl_assim .eq. 0) then
+ call cp_chl_stat
+ endif
+
+ if ((drv%nut .eq. 1) .or. (drv%multiv.eq.1)) then
+ if((bio%O2o .eq. 1) .and. (bio%N3n .eq. 1)) then
+ call wrt_o2o_stat
+ call wrt_nut_stat
+ else if((bio%O2o .eq. 1) .and. (bio%N3n .eq. 0)) then
+ call wrt_o2o_stat
+ call cp_nut_stat
+ else if((bio%O2o .eq. 0) .and. (bio%N3n .eq. 1)) then
+ call cp_o2o_stat
+ call wrt_nut_stat
+ endif
endif
call sav_itr
diff --git a/rdeofs_chl.f90 b/rdeofs_chl.f90
new file mode 100644
index 0000000..9f32a38
--- /dev/null
+++ b/rdeofs_chl.f90
@@ -0,0 +1,143 @@
+subroutine rdeofs_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 . !
+ ! !
+ !---------------------------------------------------------------------------
+
+ !-----------------------------------------------------------------------
+ ! !
+ ! 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 grd_str
+ use filenames
+
+ use mpi_str
+ use pnetcdf
+
+ implicit none
+
+ INTEGER(i4) :: stat, ncid, idvar
+ integer(8) :: neofs, nlevs, nregs
+ integer(KIND=MPI_OFFSET_KIND) :: GlobalStart(3), GlobalCount(3)
+ real(4), allocatable :: x3(:,:,:), x2(:,:)
+
+ stat = nf90mpi_open(Var3DCommunicator, trim(EOF_FILE_CHL), NF90_NOWRITE, MPI_INFO_NULL, ncid)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_open "//trim(EOF_FILE_CHL), stat)
+
+ ! Get dimensions
+ stat = nf90mpi_inq_dimid (ncid, 'nreg', idvar)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_inq_dimid nreg", stat)
+ stat = nfmpi_inq_dimlen (ncid, idvar, nregs)
+ if (stat /= nf90_noerr) call handle_err("nfmpi_inq_dimlen nregs", stat)
+ stat = nf90mpi_inq_dimid (ncid, 'nlev', idvar)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_inq_dimid nlev", stat)
+ stat = nfmpi_inq_dimlen (ncid, idvar, nlevs)
+ if (stat /= nf90_noerr) call handle_err("nfmpi_inq_dimlen nlevs", stat)
+ stat = nf90mpi_inq_dimid (ncid, 'neof', idvar)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_inq_dimid neof", stat)
+ stat = nfmpi_inq_dimlen (ncid, idvar, len = neofs)
+ if (stat /= nf90_noerr) call handle_err("nfmpi_inq_dimlen neofs", stat)
+
+ if(MyId .eq. 0) then
+ write(drv%dia,*)'Eof dimensions for chl are: ',ros%nreg, ros%kmt, neofs
+ write(drv%dia,*)'Uses ',ros%neof_chl,' eofs.'
+ endif
+
+ if(ros%nreg .ne. nregs) then
+
+ if(MyId .eq. 0) &
+ write(drv%dia,*)'Error: ros%nreg differs from nregs'
+
+ call MPI_Abort(Var3DCommunicator, -1, stat)
+
+ endif
+
+ if(ros%neof_chl .gt. neofs) then
+
+ if(MyId .eq. 0) &
+ write(drv%dia,*)'Error: Requires more Eofs than available in the input file.'
+ call MPI_Abort(Var3DCommunicator, -1, stat)
+
+ else if(ros%neof_chl .lt. neofs) then
+
+ if(MyId .eq. 0) then
+ write(drv%dia,*)'Warning: ros%neof_chl < neofs!'
+ write(drv%dia,*)'ros%neof_chl =', ros%neof_chl
+ write(drv%dia,*)'neofs =', neofs
+ write(drv%dia,*)'continue using ros%neof_chl'
+ write(*,*)'Warning: ros%neof_chl < neofs!'
+ write(*,*)'ros%neof_chl =', ros%neof_chl
+ write(*,*)'neofs =', neofs
+ write(*,*)'continue using ros%neof_chl'
+ endif
+ endif
+
+ if(ros%kmt .ne. nlevs) then
+ if(MyId .eq. 0) &
+ write(drv%dia,*)'Error: Vertical dimension different than in the input file.'
+
+ call MPI_Abort(Var3DCommunicator, -1, stat)
+ endif
+
+ ! Allocate eof arrays and get data
+ ALLOCATE ( ros%evc_chl( ros%nreg, ros%kmt, ros%neof_chl) ) ; ros%evc_chl = huge(ros%evc_chl(1,1,1))
+ ALLOCATE ( ros%eva_chl( ros%nreg, ros%neof_chl) ) ; ros%eva_chl = huge(ros%eva_chl(1,1))
+ ALLOCATE ( x3( ros%nreg, ros%kmt, ros%neof_chl) )
+ ALLOCATE ( x2( ros%nreg, ros%neof_chl) )
+ GlobalStart(:) = 1
+ GlobalCount(1) = ros%nreg
+ GlobalCount(2) = ros%kmt
+ GlobalCount(3) = ros%neof_chl
+
+ stat = nf90mpi_inq_varid(ncid, 'evc', idvar)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_inq_varid evc", stat)
+ stat = nfmpi_get_vara_real_all(ncid,idvar,GlobalStart, GlobalCount, x3)
+ if (stat /= nf90_noerr) call handle_err("nfmpi_get_vara_real_all eva", stat)
+
+ ros%evc_chl(:,:,:) = x3(:,:,:)
+
+ GlobalCount(1) = ros%nreg
+ GlobalCount(2) = ros%neof_chl
+
+ stat = nf90mpi_inq_varid(ncid, 'eva', idvar)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_inq_varid eva", stat)
+ stat = nfmpi_get_vara_real_all(ncid,idvar,GlobalStart(1:2), GlobalCount(1:2), x2)
+ if (stat /= nf90_noerr) call handle_err("nfmpi_get_vara_real_all", stat)
+ ros%eva_chl(:,:) = x2(:,:)
+
+ ! DECOMMENT FOLLOWING TWO LINES TO MAKE FILTER TEST
+ ! ros%evc_chl(:,:,:) = 1.
+ ! ros%eva_chl(:,:) = 1.
+
+ stat = nf90mpi_close(ncid)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_close", stat)
+
+ DEALLOCATE(x3, x2)
+
+end subroutine rdeofs_chl
+
+
diff --git a/rdeofs_multi.f90 b/rdeofs_multi.f90
new file mode 100644
index 0000000..2dfcbc7
--- /dev/null
+++ b/rdeofs_multi.f90
@@ -0,0 +1,212 @@
+subroutine rdeofs_multi
+
+ !---------------------------------------------------------------------------
+ ! !
+ ! 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 grd_str
+ use filenames
+
+ use mpi_str
+ use pnetcdf
+
+ implicit none
+
+ INTEGER(i4) :: stat, ncid, idvar
+ INTEGER(8) :: ik,ireg
+ integer(8) :: neofs, nlevs, nregs, nregsstd
+ integer(KIND=MPI_OFFSET_KIND) :: GlobalStart(3), GlobalCount(3)
+ real(4), allocatable :: std_chl(:),std_n3n(:)
+ real(4), allocatable :: x3(:,:,:), x2(:,:), x1(:)
+
+
+ ! Read std file for normalization
+ stat = nf90mpi_open(Var3DCommunicator, trim(STD_FILE_MULTI), NF90_NOWRITE, MPI_INFO_NULL, ncid)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_open "//trim(STD_FILE_MULTI), stat)
+
+ ! Get dimensions
+ stat = nf90mpi_inq_dimid (ncid, 'nreg', idvar)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_inq_dimid nreg", stat)
+ stat = nfmpi_inq_dimlen (ncid, idvar, nregsstd)
+ if (stat /= nf90_noerr) call handle_err("nfmpi_inq_dimlen nregsstd", stat)
+
+ if(MyId .eq. 0) then
+ write(drv%dia,*)'Number of reg in std file : ',nregsstd
+ write(drv%dia,*)'Uses ',ros%neof_multi,' eofs.'
+ endif
+
+ if(ros%nreg .ne. nregsstd) then
+
+ if(MyId .eq. 0) &
+ write(drv%dia,*)'Error: nregsstd differs from nregs'
+
+ call MPI_Abort(Var3DCommunicator, -1, stat)
+
+ endif
+
+ ! Allocate eof arrays and get data
+ ALLOCATE ( std_chl( ros%nreg ) ) ; std_chl = huge(std_chl(1))
+ ALLOCATE ( std_n3n( ros%nreg ) ) ; std_n3n = huge(std_n3n(1))
+ ALLOCATE ( x1( ros%nreg ) )
+ GlobalStart(:) = 1
+ GlobalCount(1) = ros%nreg
+ GlobalCount(2) = ros%kmchl+ros%kmnit
+ GlobalCount(3) = ros%neof_multi
+
+ stat = nf90mpi_inq_varid(ncid, 'stdP_l', idvar)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_inq_varid evc", stat)
+ stat = nfmpi_get_vara_real_all(ncid,idvar,GlobalStart(1), GlobalCount(1), x1)
+ if (stat /= nf90_noerr) call handle_err("nfmpi_get_vara_real_all eva", stat)
+
+ std_chl(:) = x1(:)
+
+ stat = nf90mpi_inq_varid(ncid, 'stdN3n', idvar)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_inq_varid eva", stat)
+ stat = nfmpi_get_vara_real_all(ncid,idvar,GlobalStart(1), GlobalCount(1), x1)
+ if (stat /= nf90_noerr) call handle_err("nfmpi_get_vara_real_all", stat)
+
+ std_n3n(:) = x1(:)
+
+ ! DECOMMENT FOLLOWING TWO LINES TO MAKE FILTER TEST
+ ! ros%evc_multi(:,:,:) = 1.
+ ! ros%eva_multi(:,:) = 1.
+
+ stat = nf90mpi_close(ncid)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_close", stat)
+
+
+
+
+ stat = nf90mpi_open(Var3DCommunicator, trim(EOF_FILE_MULTI), NF90_NOWRITE, MPI_INFO_NULL, ncid)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_open "//trim(EOF_FILE_MULTI), stat)
+
+ ! Get dimensions
+ stat = nf90mpi_inq_dimid (ncid, 'nreg', idvar)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_inq_dimid nreg", stat)
+ stat = nfmpi_inq_dimlen (ncid, idvar, nregs)
+ if (stat /= nf90_noerr) call handle_err("nfmpi_inq_dimlen nregs", stat)
+ stat = nf90mpi_inq_dimid (ncid, 'nlev', idvar)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_inq_dimid nlev", stat)
+ stat = nfmpi_inq_dimlen (ncid, idvar, nlevs)
+ if (stat /= nf90_noerr) call handle_err("nfmpi_inq_dimlen nlevs", stat)
+ stat = nf90mpi_inq_dimid (ncid, 'neof', idvar)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_inq_dimid neof", stat)
+ stat = nfmpi_inq_dimlen (ncid, idvar, len = neofs)
+ if (stat /= nf90_noerr) call handle_err("nfmpi_inq_dimlen neofs", stat)
+
+ if(MyId .eq. 0) then
+ write(drv%dia,*)'Eof dimensions for multivariate are: ',ros%nreg, ros%kmchl+ros%kmnit, neofs
+ write(drv%dia,*)'Uses ',ros%neof_multi,' eofs.'
+ endif
+
+ if(ros%nreg .ne. nregs) then
+
+ if(MyId .eq. 0) &
+ write(drv%dia,*)'Error: ros%nreg differs from nregs'
+
+ call MPI_Abort(Var3DCommunicator, -1, stat)
+
+ endif
+
+ if(ros%neof_multi .gt. neofs) then
+
+ if(MyId .eq. 0) &
+ write(drv%dia,*)'Error: Requires more Eofs than available in the input file.'
+ call MPI_Abort(Var3DCommunicator, -1, stat)
+
+ else if(ros%neof_multi .lt. neofs) then
+
+ if(MyId .eq. 0) then
+ write(drv%dia,*)'Warning: ros%neof_multi < neofs!'
+ write(drv%dia,*)'ros%neof_multi =', ros%neof_multi
+ write(drv%dia,*)'neofs =', neofs
+ write(drv%dia,*)'continue using ros%neof_multi'
+ write(*,*)'Warning: ros%neof_multi < neofs!'
+ write(*,*)'ros%neof_multi =', ros%neof_multi
+ write(*,*)'neofs =', neofs
+ write(*,*)'continue using ros%neof_multi'
+ endif
+ endif
+
+ if((ros%kmchl+ros%kmnit) .ne. nlevs) then
+ if(MyId .eq. 0) &
+ write(drv%dia,*)'Error: Vertical dimension different than in the input file.'
+
+ call MPI_Abort(Var3DCommunicator, -1, stat)
+ endif
+
+ ! Allocate eof arrays and get data
+ ALLOCATE ( ros%evc_multi( ros%nreg, ros%kmchl+ros%kmnit, ros%neof_multi) ) ; ros%evc_multi = huge(ros%evc_multi(1,1,1))
+ ALLOCATE ( ros%eva_multi( ros%nreg, ros%neof_multi) ) ; ros%eva_multi = huge(ros%eva_multi(1,1))
+ ALLOCATE ( x3( ros%nreg, ros%kmchl+ros%kmnit, ros%neof_multi) )
+ ALLOCATE ( x2( ros%nreg, ros%neof_multi) )
+ GlobalStart(:) = 1
+ GlobalCount(1) = ros%nreg
+ GlobalCount(2) = ros%kmchl+ros%kmnit
+ GlobalCount(3) = ros%neof_multi
+
+ stat = nf90mpi_inq_varid(ncid, 'evc', idvar)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_inq_varid evc", stat)
+ stat = nfmpi_get_vara_real_all(ncid,idvar,GlobalStart, GlobalCount, x3)
+ if (stat /= nf90_noerr) call handle_err("nfmpi_get_vara_real_all eva", stat)
+
+ ros%evc_multi(:,:,:) = x3(:,:,:)
+
+ do ireg=1,ros%nreg
+ do ik=1,ros%kmchl
+ ros%evc_multi(ireg,ik,:) = ros%evc_multi(ireg,ik,:)*std_chl(ireg)
+ enddo
+ do ik=ros%kmchl+1,ros%kmchl+ros%kmnit
+ ros%evc_multi(ireg,ik,:) = ros%evc_multi(ireg,ik,:)*std_n3n(ireg)
+ enddo
+ enddo
+
+ GlobalCount(1) = ros%nreg
+ GlobalCount(2) = ros%neof_multi
+
+ stat = nf90mpi_inq_varid(ncid, 'eva', idvar)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_inq_varid eva", stat)
+ stat = nfmpi_get_vara_real_all(ncid,idvar,GlobalStart(1:2), GlobalCount(1:2), x2)
+ if (stat /= nf90_noerr) call handle_err("nfmpi_get_vara_real_all", stat)
+ ros%eva_multi(:,:) = x2(:,:)
+
+ ! DECOMMENT FOLLOWING TWO LINES TO MAKE FILTER TEST
+ ! ros%evc_multi(:,:,:) = 1.
+ ! ros%eva_multi(:,:) = 1.
+
+ stat = nf90mpi_close(ncid)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_close", stat)
+
+ DEALLOCATE(x3, x2, std_chl, std_n3n)
+
+end subroutine rdeofs_multi
+
+
diff --git a/rdeofs.f90 b/rdeofs_n3n.f90
similarity index 80%
rename from rdeofs.f90
rename to rdeofs_n3n.f90
index 3a21179..5e158f2 100644
--- a/rdeofs.f90
+++ b/rdeofs_n3n.f90
@@ -1,4 +1,4 @@
-subroutine rdeofs
+subroutine rdeofs_n3n
!---------------------------------------------------------------------------
! !
@@ -45,9 +45,9 @@ subroutine rdeofs
integer(KIND=MPI_OFFSET_KIND) :: GlobalStart(3), GlobalCount(3)
real(4), allocatable :: x3(:,:,:), x2(:,:)
- ! stat = nf90_open(trim(EOF_FILE), NF90_NOWRITE, ncid)
- stat = nf90mpi_open(Var3DCommunicator, trim(EOF_FILE), NF90_NOWRITE, MPI_INFO_NULL, ncid)
- if (stat /= nf90_noerr) call handle_err("nf90mpi_open", stat)
+
+ stat = nf90mpi_open(Var3DCommunicator, trim(EOF_FILE_N3N), NF90_NOWRITE, MPI_INFO_NULL, ncid)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_open "//trim(EOF_FILE_N3N), stat)
! Get dimensions
stat = nf90mpi_inq_dimid (ncid, 'nreg', idvar)
@@ -64,8 +64,8 @@ subroutine rdeofs
if (stat /= nf90_noerr) call handle_err("nfmpi_inq_dimlen neofs", stat)
if(MyId .eq. 0) then
- write(drv%dia,*)'Eof dimensions are: ',ros%nreg, ros%kmt, neofs
- write(drv%dia,*)'Uses ',ros%neof,' eofs.'
+ write(drv%dia,*)'Eof dimensions for N3n are: ',ros%nreg, ros%kmt, neofs
+ write(drv%dia,*)'Uses ',ros%neof_n3n,' eofs.'
endif
if(ros%nreg .ne. nregs) then
@@ -77,19 +77,23 @@ subroutine rdeofs
endif
- if(ros%neof .gt. neofs) then
+ if(ros%neof_n3n .gt. neofs) then
if(MyId .eq. 0) &
write(drv%dia,*)'Error: Requires more Eofs than available in the input file.'
call MPI_Abort(Var3DCommunicator, -1, stat)
- else if(ros%neof .lt. neofs) then
+ else if(ros%neof_n3n .lt. neofs) then
if(MyId .eq. 0) then
- write(drv%dia,*)'Warning: ros%neof < neofs!'
- write(drv%dia,*)'ros%neof =', ros%neof
+ write(drv%dia,*)'Warning: ros%neof_n3n < neofs!'
+ write(drv%dia,*)'ros%neof_n3n =', ros%neof_n3n
write(drv%dia,*)'neofs =', neofs
- write(drv%dia,*)'continue using ros%neof'
+ write(drv%dia,*)'continue using ros%neof_n3n'
+ write(*,*)'Warning: ros%neof_n3n < neofs!'
+ write(*,*)'ros%neof_n3n =', ros%neof_n3n
+ write(*,*)'neofs =', neofs
+ write(*,*)'continue using ros%neof_n3n'
endif
endif
@@ -101,30 +105,30 @@ subroutine rdeofs
endif
! Allocate eof arrays and get data
- ALLOCATE ( ros%evc( ros%nreg, ros%kmt, ros%neof) ) ; ros%evc = huge(ros%evc(1,1,1))
- ALLOCATE ( ros%eva( ros%nreg, ros%neof) ) ; ros%eva = huge(ros%eva(1,1))
- ALLOCATE ( x3( ros%nreg, ros%kmt, ros%neof) )
- ALLOCATE ( x2( ros%nreg, ros%neof) )
+ ALLOCATE ( ros%evc_n3n( ros%nreg, ros%kmt, ros%neof_n3n) ) ; ros%evc_n3n = huge(ros%evc_n3n(1,1,1))
+ ALLOCATE ( ros%eva_n3n( ros%nreg, ros%neof_n3n) ) ; ros%eva_n3n = huge(ros%eva_n3n(1,1))
+ ALLOCATE ( x3( ros%nreg, ros%kmt, ros%neof_n3n) )
+ ALLOCATE ( x2( ros%nreg, ros%neof_n3n) )
GlobalStart(:) = 1
GlobalCount(1) = ros%nreg
GlobalCount(2) = ros%kmt
- GlobalCount(3) = ros%neof
+ GlobalCount(3) = ros%neof_n3n
stat = nf90mpi_inq_varid(ncid, 'evc', idvar)
if (stat /= nf90_noerr) call handle_err("nf90mpi_inq_varid evc", stat)
stat = nfmpi_get_vara_real_all(ncid,idvar,GlobalStart, GlobalCount, x3)
if (stat /= nf90_noerr) call handle_err("nfmpi_get_vara_real_all eva", stat)
- ros%evc(:,:,:) = x3(:,:,:)
+ ros%evc_n3n(:,:,:) = x3(:,:,:)
GlobalCount(1) = ros%nreg
- GlobalCount(2) = ros%neof
+ GlobalCount(2) = ros%neof_n3n
stat = nf90mpi_inq_varid(ncid, 'eva', idvar)
if (stat /= nf90_noerr) call handle_err("nf90mpi_inq_varid eva", stat)
stat = nfmpi_get_vara_real_all(ncid,idvar,GlobalStart(1:2), GlobalCount(1:2), x2)
if (stat /= nf90_noerr) call handle_err("nfmpi_get_vara_real_all", stat)
- ros%eva(:,:) = x2(:,:)
+ ros%eva_n3n(:,:) = x2(:,:)
! DECOMMENT FOLLOWING TWO LINES TO MAKE FILTER TEST
! ros%evc(:,:,:) = 1.
@@ -135,6 +139,6 @@ subroutine rdeofs
DEALLOCATE(x3, x2)
-end subroutine rdeofs
+end subroutine rdeofs_n3n
diff --git a/rdeofs_o2o.f90 b/rdeofs_o2o.f90
new file mode 100644
index 0000000..83290b8
--- /dev/null
+++ b/rdeofs_o2o.f90
@@ -0,0 +1,143 @@
+subroutine rdeofs_o2o
+
+ !---------------------------------------------------------------------------
+ ! !
+ ! 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 grd_str
+ use filenames
+
+ use mpi_str
+ use pnetcdf
+
+ implicit none
+
+ INTEGER(i4) :: stat, ncid, idvar
+ integer(8) :: neofs, nlevs, nregs
+ integer(KIND=MPI_OFFSET_KIND) :: GlobalStart(3), GlobalCount(3)
+ real(4), allocatable :: x3(:,:,:), x2(:,:)
+
+ stat = nf90mpi_open(Var3DCommunicator, trim(EOF_FILE_O2O), NF90_NOWRITE, MPI_INFO_NULL, ncid)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_open "//trim(EOF_FILE_O2O), stat)
+
+ ! Get dimensions
+ stat = nf90mpi_inq_dimid (ncid, 'nreg', idvar)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_inq_dimid nreg", stat)
+ stat = nfmpi_inq_dimlen (ncid, idvar, nregs)
+ if (stat /= nf90_noerr) call handle_err("nfmpi_inq_dimlen nregs", stat)
+ stat = nf90mpi_inq_dimid (ncid, 'nlev', idvar)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_inq_dimid nlev", stat)
+ stat = nfmpi_inq_dimlen (ncid, idvar, nlevs)
+ if (stat /= nf90_noerr) call handle_err("nfmpi_inq_dimlen nlevs", stat)
+ stat = nf90mpi_inq_dimid (ncid, 'neof', idvar)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_inq_dimid neof", stat)
+ stat = nfmpi_inq_dimlen (ncid, idvar, len = neofs)
+ if (stat /= nf90_noerr) call handle_err("nfmpi_inq_dimlen neofs", stat)
+
+ if(MyId .eq. 0) then
+ write(drv%dia,*)'Eof dimensions for O2o are: ',ros%nreg, ros%kmt, neofs
+ write(drv%dia,*)'Uses ',ros%neof_o2o,' eofs.'
+ endif
+
+ if(ros%nreg .ne. nregs) then
+
+ if(MyId .eq. 0) &
+ write(drv%dia,*)'Error: ros%nreg differs from nregs'
+
+ call MPI_Abort(Var3DCommunicator, -1, stat)
+
+ endif
+
+ if(ros%neof_o2o .gt. neofs) then
+
+ if(MyId .eq. 0) &
+ write(drv%dia,*)'Error: Requires more Eofs than available in the input file.'
+ call MPI_Abort(Var3DCommunicator, -1, stat)
+
+ else if(ros%neof_o2o .lt. neofs) then
+
+ if(MyId .eq. 0) then
+ write(drv%dia,*)'Warning: ros%neof_o2o < neofs!'
+ write(drv%dia,*)'ros%neof_o2o =', ros%neof_o2o
+ write(drv%dia,*)'neofs =', neofs
+ write(drv%dia,*)'continue using ros%neof_o2o'
+ write(*,*)'Warning: ros%neof_o2o < neofs!'
+ write(*,*)'ros%neof_o2o =', ros%neof_o2o
+ write(*,*)'neofs =', neofs
+ write(*,*)'continue using ros%neof_o2o'
+ endif
+ endif
+
+ if(ros%kmt .ne. nlevs) then
+ if(MyId .eq. 0) &
+ write(drv%dia,*)'Error: Vertical dimension different than in the input file.'
+
+ call MPI_Abort(Var3DCommunicator, -1, stat)
+ endif
+
+ ! Allocate eof arrays and get data
+ ALLOCATE ( ros%evc_o2o( ros%nreg, ros%kmt, ros%neof_o2o) ) ; ros%evc_o2o = huge(ros%evc_o2o(1,1,1))
+ ALLOCATE ( ros%eva_o2o( ros%nreg, ros%neof_o2o) ) ; ros%eva_o2o = huge(ros%eva_o2o(1,1))
+ ALLOCATE ( x3( ros%nreg, ros%kmt, ros%neof_o2o) )
+ ALLOCATE ( x2( ros%nreg, ros%neof_o2o) )
+ GlobalStart(:) = 1
+ GlobalCount(1) = ros%nreg
+ GlobalCount(2) = ros%kmt
+ GlobalCount(3) = ros%neof_o2o
+
+ stat = nf90mpi_inq_varid(ncid, 'evc', idvar)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_inq_varid evc", stat)
+ stat = nfmpi_get_vara_real_all(ncid,idvar,GlobalStart, GlobalCount, x3)
+ if (stat /= nf90_noerr) call handle_err("nfmpi_get_vara_real_all eva", stat)
+
+ ros%evc_o2o(:,:,:) = x3(:,:,:)
+
+ GlobalCount(1) = ros%nreg
+ GlobalCount(2) = ros%neof_o2o
+
+ stat = nf90mpi_inq_varid(ncid, 'eva', idvar)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_inq_varid eva", stat)
+ stat = nfmpi_get_vara_real_all(ncid,idvar,GlobalStart(1:2), GlobalCount(1:2), x2)
+ if (stat /= nf90_noerr) call handle_err("nfmpi_get_vara_real_all", stat)
+ ros%eva_o2o(:,:) = x2(:,:)
+
+ ! DECOMMENT FOLLOWING TWO LINES TO MAKE FILTER TEST
+ ! ros%evc_o2o(:,:,:) = 1.
+ ! ros%eva_o2o(:,:) = 1.
+
+ stat = nf90mpi_close(ncid)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_close", stat)
+
+ DEALLOCATE(x3, x2)
+
+end subroutine rdeofs_o2o
+
+
diff --git a/rdrcorr.f90 b/rdrcorr.f90
index cbddd8e..ca4a485 100644
--- a/rdrcorr.f90
+++ b/rdrcorr.f90
@@ -38,9 +38,9 @@ subroutine rdrcorr
integer(KIND=MPI_OFFSET_KIND) :: GlobalStart(3), GlobalCount(3)
real(r4), ALLOCATABLE :: x3(:,:,:)
- !write(*,*)trim(RCORR_FILE)
+ ! print*,RCORR_FILE
stat = nf90mpi_open(Var3DCommunicator, trim(RCORR_FILE), NF90_NOWRITE, MPI_INFO_NULL, ncid)
- if (stat /= nf90_noerr) call handle_err("nf90mpi_open",stat)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_open "//trim(RCORR_FILE),stat)
ALLOCATE ( x3(GlobalRow,GlobalCol,grd%km))
GlobalStart(:) = 1
diff --git a/readAnisotropy.f90 b/readAnisotropy.f90
index 4a4b4cc..db9d3f3 100644
--- a/readAnisotropy.f90
+++ b/readAnisotropy.f90
@@ -38,7 +38,7 @@ subroutine readAnisotropy
real(r4), ALLOCATABLE :: x2(:,:)
stat = nf90mpi_open(Var3DCommunicator, trim(ANIS_FILE), NF90_NOWRITE, MPI_INFO_NULL, ncid)
- if (stat /= nf90_noerr) call handle_err("nf90mpi_open",stat)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_open "//trim(ANIS_FILE),stat)
ALLOCATE ( x2(GlobalRow,GlobalCol))
GlobalStart(:) = 1
@@ -83,4 +83,4 @@ subroutine readAnisotropy
if (stat /= nf90_noerr) call handle_err("nf90mpi_close", stat)
DEALLOCATE(x2)
-end subroutine readAnisotropy
\ No newline at end of file
+end subroutine readAnisotropy
diff --git a/readChlNutCov.f90 b/readChlNutCov.f90
new file mode 100644
index 0000000..b39898b
--- /dev/null
+++ b/readChlNutCov.f90
@@ -0,0 +1,127 @@
+subroutine readChlNutCov
+
+!---------------------------------------------------------------------------
+! !
+! Copyright 2015 Anna teruzzi, OGS Trieste !
+! !
+! 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 covariances between Nitrate and Phsosphate !
+! to update Phosphate with assimilation of Nitrate !
+!---------------------------------------------------------------------------
+
+
+ use set_knd
+ use drv_str
+ use grd_str
+ use bio_str
+ use filenames
+
+ use mpi_str
+ use pnetcdf
+
+ implicit none
+
+ integer(i4) :: stat, ncid, idvar
+ integer(i4) :: i,j,k
+ !integer(KIND=MPI_OFFSET_KIND) :: GlobalStart(3), GlobalCount(3)
+ real(r4), ALLOCATABLE :: x3(:,:,:)
+
+
+ !write(*,*)trim(RCORR_FILE)
+ stat = nf90mpi_open(Var3DCommunicator, trim(NUTCHLCOV_FILE), NF90_NOWRITE, MPI_INFO_NULL, ncid)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_open "//trim(NUTCHLCOV_FILE),stat)
+
+ ALLOCATE ( x3(grd%im, grd%jm, grd%km))
+ ALLOCATE ( bio%covn3n_chl(grd%im, grd%jm, grd%km)); bio%covn3n_chl(:,:,:) = 0.0
+ ALLOCATE ( bio%covn1p_chl(grd%im, grd%jm, grd%km)); bio%covn1p_chl(:,:,:) = 0.0
+
+ ! covn3n_chl
+ x3(:,:,:) = 0.0
+
+ stat = nf90mpi_inq_varid (ncid, 'covp_l_n3n', idvar)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_inq_varid radius",stat)
+ stat = nfmpi_get_vara_real_all (ncid, idvar, MyStart, MyCount, x3)
+ if (stat /= nf90_noerr) call handle_err("nfmpi_get_vara_real_all radius",stat)
+
+ do k=1,grd%km
+ do j=1,grd%jm
+ do i=1,grd%im
+ if(x3(i,j,k) .lt. 1.e20) then
+
+ bio%covn3n_chl(i,j,k) = bio%covn3n_chl(i,j,k) + x3(i,j,k)
+
+ else
+ bio%covn3n_chl(i,j,k) = x3(i,j,k)
+ if(grd%msk(i,j,k) .eq. 1) then
+ write(*,*) "Warning!! Bad mask point in N3n N1p covaraince!"
+ write(*,*) "i=",i," j=",j," k=",k
+ write(*,*) "grd%msk(i,j,k)=",grd%msk
+ write(*,*) "bio%covn3n_chl(i,j,k)=",bio%covn3n_chl(i,j,k)
+ write(*,*) "Aborting.."
+ call MPI_Abort(Var3DCommunicator, -1, stat)
+ endif
+
+ endif
+
+ enddo
+ enddo
+ enddo
+
+
+ ! covn1p_chl
+ x3(:,:,:) = 0.0
+
+ stat = nf90mpi_inq_varid (ncid, 'covp_l_n1p', idvar)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_inq_varid radius",stat)
+ stat = nfmpi_get_vara_real_all (ncid, idvar, MyStart, MyCount, x3)
+ if (stat /= nf90_noerr) call handle_err("nfmpi_get_vara_real_all radius",stat)
+
+ do k=1,grd%km
+ do j=1,grd%jm
+ do i=1,grd%im
+ if(x3(i,j,k) .lt. 1.e20) then
+
+ bio%covn1p_chl(i,j,k) = bio%covn1p_chl(i,j,k) + x3(i,j,k)
+
+ else
+ bio%covn1p_chl(i,j,k) = x3(i,j,k)
+ if(grd%msk(i,j,k) .eq. 1) then
+ write(*,*) "Warning!! Bad mask point in N3n N1p covaraince!"
+ write(*,*) "i=",i," j=",j," k=",k
+ write(*,*) "grd%msk(i,j,k)=",grd%msk
+ write(*,*) "bio%covn1p_chl(i,j,k)=",bio%covn1p_chl(i,j,k)
+ write(*,*) "Aborting.."
+ call MPI_Abort(Var3DCommunicator, -1, stat)
+ endif
+
+ endif
+
+ enddo
+ enddo
+ enddo
+
+
+ stat = nf90mpi_close(ncid)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_close", stat)
+
+ DEALLOCATE(x3)
+
+end subroutine readChlNutCov
diff --git a/readBioStat.f90 b/readChlStat.f90
similarity index 92%
rename from readBioStat.f90
rename to readChlStat.f90
index 81cb176..9dcd9d5 100644
--- a/readBioStat.f90
+++ b/readChlStat.f90
@@ -1,10 +1,10 @@
-subroutine readBioStat
+subroutine readChlStat
!---------------------------------------------------------------------------
-!anna !
+! !
! Copyright 2006 Srdjan Dobricic, CMCC, Bologna !
! !
-! This file is part of OceanVar. !
+! 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 !
@@ -17,13 +17,13 @@ subroutine readBioStat
! 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 . !
+! along with OceanVar. If not, see . !
! !
!---------------------------------------------------------------------------
!-----------------------------------------------------------------------
! !
-! READ quotas for biological variables !
+! READ quotas for phytoplankton variables !
! !
! Version 1: A.Teruzzi 2012 !
! This routine will have effect only if compiled with netcdf library. !
@@ -42,7 +42,7 @@ subroutine readBioStat
INTEGER(i4) :: ncid, VarId, ierr, iVar
INTEGER(i4) :: i,j,k,l,m
- CHARACTER(LEN=51) :: RstFileName
+ CHARACTER(LEN=47) :: RstFileName
CHARACTER(LEN=3) :: MyVarName
REAL(4), ALLOCATABLE :: x3(:,:,:)
@@ -57,10 +57,10 @@ subroutine readBioStat
do l=1,bio%nphy
iVar = l + bio%nphy*(m-1)
- if(iVar .gt. NBioVar) cycle
+ if(iVar .gt. NPhytoVar) cycle
MyVarName = DA_VarList(iVar)
- RstFileName = 'DA__FREQ_1/RST.'//ShortDate//'.'//MyVarName//'.nc'
+ RstFileName = 'RSTbefore.'//ShortDate//'.'//MyVarName//'.nc'
if(drv%Verbose .eq. 1) then
if(MyId .eq. 0) &
@@ -92,7 +92,7 @@ subroutine readBioStat
if(grd%msk(i,j,k) .eq. 1) then
write(*,*) "Warning!! Bad mask point in bio structure!"
write(*,*) "i=",i," j=",j," k=",k
- write(*,*) "grd%msk(i,j,k)=",grd%msk
+ write(*,*) "grd%msk(i,j,k)=",grd%msk(i,j,k)
write(*,*) "bio%InitialChl(i,j,k)=",bio%InitialChl(i,j,k)
write(*,*) "Aborting.."
call MPI_Abort(Var3DCommunicator, -1, ierr)
@@ -147,4 +147,4 @@ subroutine readBioStat
DEALLOCATE(x3)
-end subroutine readBioStat
+end subroutine readChlStat
diff --git a/readGrid.f90 b/readGrid.f90
index a2f96ee..28ef216 100644
--- a/readGrid.f90
+++ b/readGrid.f90
@@ -3,6 +3,7 @@ subroutine readGrid
use set_knd
use drv_str
use grd_str
+ use eof_str
use filenames
use mpi_str
use pnetcdf
@@ -12,14 +13,14 @@ subroutine readGrid
implicit none
- integer(i8) :: ierr, ncid
+ integer(i8) :: ierr, ncid, my_km
integer(i8) :: jpreci, jprecj
integer(i8) :: VarId
real(r4), ALLOCATABLE :: x3(:,:,:), x2(:,:), x1(:)
integer(8) :: GlobalStart(3), GlobalCount(3)
integer(KIND=MPI_OFFSET_KIND) MyOffset
- integer :: MyStatus(MPI_STATUS_SIZE)
+ integer :: MyStatus(MPI_STATUS_SIZE), tmp
!
! open grid1.nc in read-only mode
@@ -101,6 +102,20 @@ subroutine readGrid
ALLOCATE(SendTop(grd%jm), RecBottom(grd%jm))
ALLOCATE(SendBottom(grd%jm), RecTop(grd%jm))
+ ALLOCATE(SendTop_2d( grd%jm,grd%km), SendBottom_2d (grd%jm,grd%km))
+ ALLOCATE(RecBottom_2d( grd%jm,grd%km), RecTop_2d( grd%jm,grd%km))
+ if(drv%multiv.eq.0) then
+ ALLOCATE(ChlExtended_3d (grd%im+1, grd%jm, grd%km))
+ else if(drv%multiv.eq.1) then
+ ALLOCATE(ChlExtended_3d (grd%im+1, grd%jm, ros%kmchl))
+ end if
+ ALLOCATE(N3nExtended_3d (grd%im+1, grd%jm, grd%km))
+ ALLOCATE(O2oExtended_3d (grd%im+1, grd%jm, grd%km))
+
+
+
+
+
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%dep(grd%km)) ; grd%dep = huge(grd%dep(1))
@@ -120,13 +135,33 @@ subroutine readGrid
ALLOCATE ( grd%inx(GlobalRow,localCol,grd%km)) ; grd%inx = huge(grd%inx(1,1,1))
ALLOCATE ( grd%jnx(localRow,GlobalCol,grd%km)) ; grd%jnx = huge(grd%jnx(1,1,1))
- ALLOCATE ( grd%chl(grd%im,grd%jm,grd%km) ) ; grd%chl = huge(grd%chl(1,1,1))
- ALLOCATE ( grd%chl_ad(grd%im,grd%jm,grd%km) ) ; grd%chl_ad = huge(grd%chl_ad(1,1,1))
+ if(drv%multiv .eq. 0) then
+ if(drv%chl_assim .eq. 1) then
+ ALLOCATE ( grd%chl(grd%im,grd%jm,grd%km) ) ; grd%chl = huge(grd%chl(1,1,1))
+ ALLOCATE ( grd%chl_ad(grd%im,grd%jm,grd%km) ) ; grd%chl_ad = huge(grd%chl_ad(1,1,1))
+ ALLOCATE ( bio%phy(grd%im,grd%jm,grd%km,bio%nphy,bio%ncmp) ) ; bio%phy = huge(bio%phy(1,1,1,1,1))
+ ALLOCATE ( bio%phy_ad(grd%im,grd%jm,grd%km,bio%nphy,bio%ncmp) ) ; bio%phy_ad = huge(bio%phy_ad(1,1,1,1,1))
+ endif
+ if(drv%nut .eq. 1) then
+ if(bio%N3n .eq. 1) then
+ ALLOCATE ( grd%n3n(grd%im,grd%jm,grd%km) ) ; grd%n3n = huge(grd%n3n(1,1,1))
+ ALLOCATE ( grd%n3n_ad(grd%im,grd%jm,grd%km) ) ; grd%n3n_ad = huge(grd%n3n_ad(1,1,1))
+ endif
+ if(bio%O2o .eq. 1) then
+ ALLOCATE ( grd%o2o(grd%im,grd%jm,grd%km) ) ; grd%o2o = huge(grd%o2o(1,1,1))
+ ALLOCATE ( grd%o2o_ad(grd%im,grd%jm,grd%km) ) ; grd%o2o_ad = huge(grd%o2o_ad(1,1,1))
+ endif
+ endif
- if(drv%bio_assim .eq. 1) then
- ALLOCATE ( bio%phy(grd%im,grd%jm,grd%km,bio%nphy,bio%ncmp) ) ; bio%phy = huge(bio%phy(1,1,1,1,1))
- ALLOCATE ( bio%phy_ad(grd%im,grd%jm,grd%km,bio%nphy,bio%ncmp) ) ; bio%phy_ad = huge(bio%phy_ad(1,1,1,1,1))
+ else if(drv%multiv .eq. 1) then
+ ALLOCATE ( grd%chl(grd%im,grd%jm,ros%kmchl) ) ; grd%chl = huge(grd%chl(1,1,1))
+ ALLOCATE ( grd%chl_ad(grd%im,grd%jm,ros%kmchl) ) ; grd%chl_ad = huge(grd%chl_ad(1,1,1))
+ ALLOCATE ( grd%n3n(grd%im,grd%jm,ros%kmnit) ) ; grd%n3n = huge(grd%n3n(1,1,1))
+ ALLOCATE ( grd%n3n_ad(grd%im,grd%jm,ros%kmnit) ) ; grd%n3n_ad = huge(grd%n3n_ad(1,1,1))
+ ALLOCATE ( bio%phy(grd%im,grd%jm,ros%kmchl,bio%nphy,bio%ncmp) ) ; bio%phy = huge(bio%phy(1,1,1,1,1))
+ ALLOCATE ( bio%phy_ad(grd%im,grd%jm,ros%kmchl,bio%nphy,bio%ncmp) ) ; bio%phy_ad = huge(bio%phy_ad(1,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))
@@ -165,11 +200,19 @@ subroutine readGrid
grd%NextLongitude=grd%lon(1,1)
! Send to ProcTop with Tag = MyId and receiving from
! ProcBottom with Tag = ProcBottom :)
+ if(ProcBottom .eq. MPI_PROC_NULL) then
+ tmp = 100
+ else
+ tmp=ProcBottom
+ end if
+ !write(*,*) MyId, 'before MPI_Sendrecv_replace', ProcTop, ProcBottom
call MPI_Sendrecv_replace(grd%NextLongitude,1,MPI_REAL8,ProcTop,MyId,&
- ProcBottom,ProcBottom, Var3DCommunicator, MyStatus, ierr)
+ ProcBottom,tmp, Var3DCommunicator, MyStatus, ierr)
+ !write(*,*) MyId, 'after MPI_Sendrecv_replace', ProcBottom, ProcTop
if(ProcBottom .eq. MPI_PROC_NULL) grd%NextLongitude = grd%lon(grd%im,grd%jm)
endif
+ write(*,*) MyId, 'step 1'
ierr = nf90mpi_inq_varid (ncid, 'dep', VarId)
if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_inq_varid', ierr)
@@ -198,7 +241,6 @@ subroutine readGrid
! *****************************************************************************************
! *****************************************************************************************
- call CreateMpiWindows
end subroutine readGrid
@@ -207,13 +249,14 @@ subroutine DomainDecomposition
use drv_str
use mpi_str
use grd_str
+ use eof_str
implicit none
integer, allocatable :: ilcit(:,:), ilcjt(:,:), BalancedSlice(:,:)
integer(i8) :: ji, jj, TmpInt, ierr ! jpi, jpj, nn, i
integer(i8) :: GlobalRestCol, GlobalRestRow
- integer(i8) :: i, j, k, kk
+ integer(i8) :: i, j, k, kk, my_km
integer(i8) :: NCoastX, NCoastY, TmpCoast
integer(i8) :: NRows, NCols
integer(i8) :: SliceRestRow, SliceRestCol
@@ -302,10 +345,16 @@ subroutine DomainDecomposition
SendDisplX3D(1) = 0
RecDisplX3D(1) = 0
+ SendDisplX3D_chl(1) = 0
+ RecDisplX3D_chl(1) = 0
SendDisplX2D(1) = 0
RecDisplX2D(1) = 0
+ my_km = grd%km
+ if(drv%multiv.eq.1) &
+ my_km = ros%kmchl
+
do i=1,NumProcI
if(i-1 .lt. SliceRestCol) then
OffsetRow = 1
@@ -322,6 +371,9 @@ subroutine DomainDecomposition
SendCountX3D(i) = (grd%jm / NumProcI + OffsetRow) * grd%im * grd%km
RecCountX3D(i) = localCol * grd%km * (GlobalRow / NumProcI + OffsetCol)
+ SendCountX3D_chl(i) = (grd%jm / NumProcI + OffsetRow) * grd%im * my_km
+ RecCountX3D_chl(i) = localCol * my_km * (GlobalRow / NumProcI + OffsetCol)
+
SendCountX2D(i) = (grd%jm / NumProcI + OffsetRow) * grd%im
RecCountX2D(i) = localCol * (GlobalRow / NumProcI + OffsetCol)
@@ -329,6 +381,9 @@ subroutine DomainDecomposition
SendDisplX3D(i+1) = SendDisplX3D(i) + SendCountX3D(i)
RecDisplX3D(i+1) = RecDisplX3D(i) + RecCountX3D(i)
+ SendDisplX3D_chl(i+1) = SendDisplX3D_chl(i) + SendCountX3D_chl(i)
+ RecDisplX3D_chl(i+1) = RecDisplX3D_chl(i) + RecCountX3D_chl(i)
+
SendDisplX2D(i+1) = SendDisplX2D(i) + SendCountX2D(i)
RecDisplX2D(i+1) = RecDisplX2D(i) + RecCountX2D(i)
end if
@@ -431,22 +486,4 @@ subroutine handle_err(err_msg, errcode)
end subroutine handle_err
-subroutine CreateMpiWindows
-
- use grd_str
- use mpi_str
-
- implicit none
- ! include "mpif.h"
-
- integer :: ierr
- integer(kind=MPI_ADDRESS_KIND) :: nbytes, lenreal, dummy
-
- ! lenreal = 8
- call MPI_Type_get_extent(MPI_REAL8, dummy, lenreal, ierr)
- nbytes = grd%im*grd%jm*grd%km*lenreal
-
- call MPI_Win_create(grd%chl, nbytes, lenreal, MPI_INFO_NULL, Var3DCommunicator, MpiWinChl, ierr)
- call MPI_Win_create(grd%chl_ad, nbytes, lenreal, MPI_INFO_NULL, Var3DCommunicator, MpiWinChlAd, ierr)
-end subroutine CreateMpiWindows
diff --git a/readNutCov.f90 b/readNutCov.f90
new file mode 100644
index 0000000..1595d71
--- /dev/null
+++ b/readNutCov.f90
@@ -0,0 +1,91 @@
+subroutine readNutCov
+
+!---------------------------------------------------------------------------
+! !
+! Copyright 2015 Anna teruzzi, OGS Trieste !
+! !
+! 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 covariances between Nitrate and Phsosphate !
+! to update Phosphate with assimilation of Nitrate !
+!---------------------------------------------------------------------------
+
+
+ use set_knd
+ use drv_str
+ use grd_str
+ use bio_str
+ use filenames
+
+ use mpi_str
+ use pnetcdf
+
+ implicit none
+
+ integer(i4) :: stat, ncid, idvar
+ integer(i4) :: i,j,k
+ !integer(KIND=MPI_OFFSET_KIND) :: GlobalStart(3), GlobalCount(3)
+ real(r4), ALLOCATABLE :: x3(:,:,:)
+
+ ALLOCATE ( x3(grd%im, grd%jm, grd%km))
+ ALLOCATE ( bio%covn3n_n1p(grd%im, grd%jm, grd%km)); bio%covn3n_n1p(:,:,:) = 0.0
+
+ x3(:,:,:) = 0.0
+
+ !write(*,*)trim(RCORR_FILE)
+ stat = nf90mpi_open(Var3DCommunicator, trim(NUTCOV_FILE), NF90_NOWRITE, MPI_INFO_NULL, ncid)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_open "//trim(NUTCOV_FILE),stat)
+
+ stat = nf90mpi_inq_varid (ncid, 'covn3n_n1p', idvar)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_inq_varid radius",stat)
+ stat = nfmpi_get_vara_real_all (ncid, idvar, MyStart, MyCount, x3)
+ if (stat /= nf90_noerr) call handle_err("nfmpi_get_vara_real_all radius",stat)
+
+ do k=1,grd%km
+ do j=1,grd%jm
+ do i=1,grd%im
+ if(x3(i,j,k) .lt. 1.e20) then
+
+ bio%covn3n_n1p(i,j,k) = bio%covn3n_n1p(i,j,k) + x3(i,j,k)
+
+ else
+ bio%covn3n_n1p(i,j,k) = x3(i,j,k)
+ if(grd%msk(i,j,k) .eq. 1) then
+ write(*,*) "Warning!! Bad mask point in N3n N1p covaraince!"
+ write(*,*) "i=",i," j=",j," k=",k
+ write(*,*) "grd%msk(i,j,k)=",grd%msk
+ write(*,*) "bio%covn3n_n1p(i,j,k)=",bio%covn3n_n1p(i,j,k)
+ write(*,*) "Aborting.."
+ call MPI_Abort(Var3DCommunicator, -1, stat)
+ endif
+
+ endif
+
+ enddo
+ enddo
+ enddo
+
+
+ stat = nf90mpi_close(ncid)
+ if (stat /= nf90_noerr) call handle_err("nf90mpi_close", stat)
+
+ DEALLOCATE(x3)
+
+end subroutine readNutCov
diff --git a/readNutStat.f90 b/readNutStat.f90
new file mode 100644
index 0000000..a9d84a5
--- /dev/null
+++ b/readNutStat.f90
@@ -0,0 +1,122 @@
+subroutine readNutStat
+
+!---------------------------------------------------------------------------
+! !
+! 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 quotas for nutrient variables !
+! !
+! Version 1: A.Teruzzi 2012 !
+! This routine will have effect only if compiled with netcdf library. !
+!-----------------------------------------------------------------------
+
+ ! use filenames
+ use da_params
+ use bio_str
+ use grd_str
+ use drv_str
+ use mpi_str
+ use pnetcdf
+
+ implicit none
+
+ INTEGER(i4) :: ncid, VarId, ierr, iVar
+ INTEGER(i4) :: i,j,k,l
+
+ CHARACTER(LEN=47) :: RstFileName
+ CHARACTER(LEN=3) :: MyVarName
+ REAL(4), ALLOCATABLE :: x3(:,:,:)
+
+ ALLOCATE(x3(grd%im, grd%jm, grd%km))
+ ALLOCATE(bio%InitialNut(grd%im, grd%jm, grd%km, NNutVar)) ; bio%InitialNut(:,:,:,:) = 0.0
+
+ x3(:,:,:) = 0.0
+
+
+
+ do l=1,NNutVar
+ iVar = NPhytoVar + l
+
+ if(iVar .gt. NBioVar) then
+ if(MyId .eq. 0) &
+ write(*,*) "Warning: Reading a variable not in the DA_VarList!"
+ endif
+
+ MyVarName = DA_VarList(iVar)
+ RstFileName = 'RSTbefore.'//ShortDate//'.'//MyVarName//'.nc'
+
+ if(drv%Verbose .eq. 1) then
+ if(MyId .eq. 0) &
+ write(*,*) "Reading ", RstFileName, " date: ", DA_DATE
+ endif
+
+ ierr = nf90mpi_open(Var3DCommunicator, trim(RstFileName), NF90_NOWRITE, MPI_INFO_NULL, ncid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_open RST', ierr)
+
+ ierr = nf90mpi_inq_varid (ncid, DA_VarList(iVar), VarId)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_inq_varid', ierr)
+ ierr = nfmpi_get_vara_real_all (ncid, VarId, MyStart, MyCount, x3)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nfmpi_get_vara_real_all RST', ierr)
+
+ do k=1,grd%km
+ do j=1,grd%jm
+ do i=1,grd%im
+
+ if(x3(i,j,k) .lt. 1.e20) then
+
+ bio%InitialNut(i,j,k,l) = bio%InitialNut(i,j,k,l) + x3(i,j,k)
+
+ else
+ bio%InitialNut(i,j,k,l) = x3(i,j,k)
+ if(grd%msk(i,j,k) .eq. 1) then
+ write(*,*) "Warning!! Bad mask point in bio structure!"
+ write(*,*) "i=",i," j=",j," k=",k
+ write(*,*) "grd%msk(i,j,k)=",grd%msk(i,j,k)
+ write(*,*) "bio%InitialNut(i,j,k)=",bio%InitialNut(i,j,k,l)
+ write(*,*) "Aborting.."
+ call MPI_Abort(Var3DCommunicator, -1, ierr)
+ endif
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ ierr = nf90mpi_close(ncid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_close RST', ierr)
+
+ if(drv%Verbose .eq. 1) then
+ if(MyId .eq. 0) &
+ write(*,*) "Restart ", RstFileName, " read"
+ endif
+
+ enddo
+
+
+
+ if(MyId .eq. 0) then
+ write(drv%dia,*)'Number of Nutrients is ', NNutVar
+ endif
+
+ DEALLOCATE(x3)
+
+end subroutine readNutStat
diff --git a/res_inc.f90 b/res_inc.f90
index e50a492..edc891b 100644
--- a/res_inc.f90
+++ b/res_inc.f90
@@ -33,10 +33,26 @@ subroutine res_inc
use drv_str
use grd_str
use obs_str
+ use bio_str
implicit none
- grd%chl_ad(:,:,:) = 0.0 ! OMP
+ if (drv%multiv .eq. 0) then
+ if (drv%chl_assim .eq. 1) then
+ grd%chl_ad(:,:,:) = 0.0 ! OMP
+ end if
+
+ if (drv%nut .eq. 1) then
+ if (bio%n3n .eq. 1) &
+ grd%n3n_ad(:,:,:) = 0.0
+ if (bio%o2o .eq. 1) &
+ grd%o2o_ad(:,:,:) = 0.0
+ endif
+
+ else if(drv%multiv .eq.1) then
+ grd%chl_ad(:,:,:) = 0.0 ! OMP
+ grd%n3n_ad(:,:,:) = 0.0
+ endif
obs%gra(:) = obs%amo(:) / obs%err(:) ! OMP
diff --git a/resid.f90 b/resid.f90
index 9208be9..faba056 100644
--- a/resid.f90
+++ b/resid.f90
@@ -50,9 +50,10 @@ subroutine resid
endif
enddo
endif
+
! ---
- ! Observations of chlorophyll
+ ! Observations of satellite chlorophyll
if(drv%sat_obs .eq. 1) then
do i=1,sat%no
if(sat%flc(i).eq.1)then
diff --git a/sav_itr.f90 b/sav_itr.f90
index 0c07495..6df2aff 100644
--- a/sav_itr.f90
+++ b/sav_itr.f90
@@ -40,11 +40,10 @@ subroutine sav_itr
use rcfl
use mpi_str
use bio_str
+ use da_params
implicit none
- ! free MPI RMA Windows
- call FreeWindows
! ---
! Grid structure
@@ -66,10 +65,33 @@ subroutine sav_itr
DEALLOCATE( grd%bex)
DEALLOCATE( grd%bey)
- ! Biological vectors
- DEALLOCATE( grd%chl)
- DEALLOCATE( grd%chl_ad)
-
+ ! Chlorophyll vectors
+ if(drv%multiv.eq.0) then
+
+ if(drv%chl_assim .eq. 1) then
+ DEALLOCATE( grd%chl)
+ DEALLOCATE( grd%chl_ad)
+ endif
+ if(drv%nut .eq. 1) then
+ if(bio%n3n .eq. 1) then
+ DEALLOCATE( grd%n3n)
+ DEALLOCATE( grd%n3n_ad)
+ endif
+ if(bio%o2o .eq. 1) then
+ DEALLOCATE( grd%o2o)
+ DEALLOCATE( grd%o2o_ad)
+ endif
+ endif
+
+ endif
+
+ if(drv%multiv.eq.1) then
+ DEALLOCATE( grd%chl)
+ DEALLOCATE( grd%chl_ad)
+ DEALLOCATE( grd%n3n)
+ DEALLOCATE( grd%n3n_ad)
+ endif
+
! Observational vector
DEALLOCATE( obs%inc, obs%amo, obs%res)
DEALLOCATE( obs%err, obs%gra)
@@ -77,16 +99,52 @@ subroutine sav_itr
! Covariances structure
DEALLOCATE( grd%ro)
DEALLOCATE( grd%ro_ad)
- DEALLOCATE( ros%evc, ros%eva )
+ if(drv%chl_assim .eq. 1) then
+ DEALLOCATE( ros%evc_chl, ros%eva_chl )
+ endif
+ if(drv%nut .eq. 1) then
+ if(bio%N3n .eq. 1) then
+ DEALLOCATE( ros%evc_n3n, ros%eva_n3n )
+ endif
+ if(bio%O2o .eq. 1) then
+ DEALLOCATE( ros%evc_o2o, ros%eva_o2o )
+ endif
+ endif
! Control structure
DEALLOCATE( ctl%x_c, ctl%g_c)
! Bio structure
- if(drv%bio_assim .eq. 1) then
+ if(drv%multiv.eq.0) then
+ if(drv%chl_assim .eq. 1) then
+ DEALLOCATE( bio%phy, bio%phy_ad)
+ DEALLOCATE( bio%cquot, bio%pquot)
+ DEALLOCATE( bio%InitialChl)
+ if ((drv%nut .eq. 0) .and. (NNutVar .gt. 0)) then
+ DEALLOCATE( bio%InitialNut)
+ if (drv%chl_upnut.eq.1) then
+ ! DEALLOCATE( bio%covn3n_n1p)
+ DEALLOCATE( bio%covn1p_chl)
+ DEALLOCATE( bio%covn3n_chl)
+ endif
+ endif
+ endif
+ if(drv%nut .eq. 1) then
+ DEALLOCATE( bio%InitialNut)
+ if(bio%N3n.eq.1 .AND. bio%updateN1p.eq.1) DEALLOCATE( bio%covn3n_n1p)
+ if(drv%chl_assim .eq. 0) then
+ DEALLOCATE( bio%cquot, bio%pquot)
+ DEALLOCATE( bio%InitialChl) !used in cp_chl_stat
+ endif
+ endif
+ endif
+
+ if(drv%multiv.eq.1) then
DEALLOCATE( bio%phy, bio%phy_ad)
DEALLOCATE( bio%cquot, bio%pquot)
DEALLOCATE( bio%InitialChl)
+ DEALLOCATE( bio%InitialNut)
+ if(bio%updateN1p.eq.1) DEALLOCATE( bio%covn3n_n1p)
endif
DEALLOCATE(SurfaceWaterPoints)
@@ -101,21 +159,10 @@ subroutine sav_itr
DEALLOCATE( bta_rcx)
DEALLOCATE( alp_rcy)
DEALLOCATE( bta_rcy)
+ DEALLOCATE( grd%global_msk)
if(MyId .eq. 0) write(*,*) ' DEALLOCATION DONE'
end subroutine sav_itr
-subroutine FreeWindows
-
- use grd_str
- use mpi_str
-
- implicit none
-
- integer ierr
-
- call MPI_Win_free(MpiWinChl, ierr)
- call MPI_Win_free(MpiWinChlAd, ierr)
-end subroutine FreeWindows
\ No newline at end of file
diff --git a/tao_minimizer.f90 b/tao_minimizer.f90
index d25c147..5f13d71 100644
--- a/tao_minimizer.f90
+++ b/tao_minimizer.f90
@@ -1,23 +1,33 @@
subroutine tao_minimizer
+#include "petscversion.h"
+#if PETSC_VERSION_GE(3,8,0)
+#include "petsc/finclude/petscvec.h"
+#else
#include "petsc/finclude/petscvecdef.h"
+#endif
use drv_str
use ctl_str
use mpi_str
use petscvec
+#if PETSC_VERSION_GE(3,17,0)
+ use petsctao
+#endif
implicit none
#include "petsc/finclude/petsctao.h"
- PetscErrorCode :: ierr
- Tao :: tao
- Vec :: MyState ! array that stores the (temporary) state
- PetscInt :: n, M, GlobalStart, MyEnd
- PetscScalar :: MyTolerance
- integer(i4) :: j
- real(8) :: MaxGrad
+ PetscErrorCode :: ierr
+ Tao :: tao
+ Vec :: MyState ! array that stores the (temporary) state
+ PetscInt :: n, M, GlobalStart, MyEnd, iter!, maxfeval
+ PetscReal :: fval, gnorm, cnorm, xdiff
+ PetscReal :: MyTolerance
+ TaoConvergedReason :: reason
+ integer(i4) :: j
+ real(8) :: MaxGrad
! Working arrays
PetscInt, allocatable, dimension(:) :: loc
@@ -85,9 +95,16 @@ subroutine tao_minimizer
CHKERRQ(ierr)
! Set initial solution array, MyBounds and MyFuncAndGradient routines
+
+#if PETSC_VERSION_GE(3,17,0)
+ call TaoSetSolution(tao, MyState, ierr)
+ CHKERRQ(ierr)
+ call TaoSetObjectiveAndGradient(tao,PETSC_NULL_VEC, MyFuncAndGradient, PETSC_NULL_VEC, ierr)
+#else
call TaoSetInitialVector(tao, MyState, ierr)
CHKERRQ(ierr)
- call TaoSetObjectiveAndGradientRoutine(tao, MyFuncAndGradient, PETSC_NULL_OBJECT, ierr)
+ call TaoSetObjectiveAndGradientRoutine(tao, MyFuncAndGradient, PETSC_NULL_VEC, ierr)
+#endif
CHKERRQ(ierr)
! Calling costf in order to compute
@@ -106,14 +123,21 @@ subroutine tao_minimizer
if(MyId .eq. 0) then
print*, "Setting MyTolerance", MyTolerance
+ print*, "------- MaxGrad", MaxGrad
print*, ""
write(drv%dia,*) "Setting MyTolerance", MyTolerance
+ write(drv%dia,*) "------- MaxGrad", MaxGrad
endif
! setting tolerances
call TaoSetTolerances(tao, MyTolerance, 1.d-4, ctl%pgper, ierr)
CHKERRQ(ierr)
+ ! setting max number of fucntion evaluation
+ !maxfeval = 300
+ call TaoSetMaximumFunctionEvaluations(tao, 100, ierr)
+ CHKERRQ(ierr)
+
! calling the solver to minimize the problem
call TaoSolve(tao, ierr)
CHKERRQ(ierr)
@@ -127,8 +151,43 @@ subroutine tao_minimizer
call TaoView(tao, PETSC_VIEWER_STDOUT_WORLD, ierr)
+ call TaoGetSolutionStatus(tao, iter, fval, gnorm, cnorm, xdiff, reason, ierr)
+ if(reason .lt. 0) then
+
+ if( ((reason.eq.-6) .or. (reason.eq.-5)) .and. (drv%MyCounter .gt. 12) ) then
+ if(MyId .eq. 0) then
+ print*, "TAO failed to find a solution"
+ print*, "fval..", fval
+ print*, "gnorm.", gnorm
+ print*, "reason", reason
+ print*, "iter", iter
+ print*, " MyCount", drv%MyCounter
+ print*, "BUT assigning a solution "
+ endif
+
+ else
+ if(MyId .eq. 0) then
+ print*, "TAO failed to find a solution"
+ print*, "fval..", fval
+ print*, "gnorm.", gnorm
+ print*, "reason", reason
+ print*, "iter", iter
+ print*, " MyCount", drv%MyCounter
+ print*, "Aborting.."
+ endif
+ call MPI_Barrier(Var3DCommunicator, ierr)
+ call MPI_Abort(Var3DCommunicator, -1, ierr)
+ endif ! reason -6 or -5
+
+ endif !reason.lt.0
+
! Get the solution and copy into ctl%x_c array
+#if PETSC_VERSION_GE(3,17,0)
+ call TaoGetSolution(tao, MyState, ierr)
+#else
call TaoGetSolutionVector(tao, MyState, ierr)
+#endif
+
CHKERRQ(ierr)
call VecGetArrayReadF90(MyState, xtmp, ierr)
CHKERRQ(ierr)
@@ -171,19 +230,28 @@ end subroutine tao_minimizer
subroutine MyFuncAndGradient(tao, MyState, CostFunc, Grad, dummy, ierr)
+#include
+#if PETSC_VERSION_GE(3,8,0)
+#include "petsc/finclude/petscvec.h"
+#else
#include "petsc/finclude/petscvecdef.h"
+#endif
+#include "petsc/finclude/petsctao.h"
use set_knd
use drv_str
use ctl_str
use petscvec
+#if PETSC_VERSION_GE(3,17,0)
+ use petsctao
+#endif
use mpi_str
implicit none
-#include "petsc/finclude/petsctao.h"
- Tao :: tao
+
+ Tao :: tao
Vec :: MyState, Grad
PetscScalar :: CostFunc
PetscErrorCode :: ierr
@@ -197,9 +265,12 @@ subroutine MyFuncAndGradient(tao, MyState, CostFunc, Grad, dummy, ierr)
! and set it in ctl%x_c array in order to compute
! the actual value of Cost Function and the gradient
! with costf subroutine
+ ! VecGetArrayReadF90 function puts MyState (provided by TAO)
+ ! into xtmp pointer -> Now we can access to MyState values :)
call VecGetArrayReadF90(MyState, xtmp, ierr)
CHKERRQ(ierr)
+ ! access to MyState values
do j=1,ctl%n
ctl%x_c(j) = xtmp(j)
end do
diff --git a/veof.f90 b/veof_chl.f90
similarity index 59%
rename from veof.f90
rename to veof_chl.f90
index 0a85536..74731a3 100644
--- a/veof.f90
+++ b/veof_chl.f90
@@ -1,4 +1,4 @@
-subroutine veof
+subroutine veof_chl
!anna
!---------------------------------------------------------------------------
! !
@@ -33,43 +33,71 @@ subroutine veof
use drv_str
use grd_str
use eof_str
+ use mpi_str
implicit none
- INTEGER(i4) :: i, j, k, l,n, k1
+ INTEGER(i4) :: i, j, k, l,n, my_km, MyNEofs, ierr
REAL(r8), DIMENSION ( grd%im, grd%jm) :: egm
+ REAL(r8), ALLOCATABLE, DIMENSION(:,:) :: eva
+ REAL(r8), ALLOCATABLE, DIMENSION(:,:,:) :: evc
+ my_km = 0
+ if((drv%chl_assim .eq.1) .and. (drv%multiv .eq. 0)) then
+ MyNEofs = ros%neof_chl
+ my_km = grd%km
+ else if((drv%chl_assim .eq.0) .and. (drv%multiv .eq. 1)) then
+ MyNEofs = ros%neof_multi
+ my_km = ros%kmchl
+ endif
+
+ if(my_km .eq. 0) then
+ if(MyId .eq. 0) then
+ write(drv%dia,*) "Error! my_km for chlorophyll not setted"
+ write(drv%dia,*) "chl_assim e multiv flags should be alternatively valid"
+ write(drv%dia,*) ""
+ write(*,*) "Error! my_km for chlorophyll not setted! Aborting"
+ write(*,*) "chl_assim e multiv flags should be alternatively valid"
+ write(*,*) ""
+ endif
+ call MPI_Barrier(Var3DCommunicator, ierr)
+ call MPI_Abort(Var3DCommunicator,-1,ierr)
+ endif
+
+ ALLOCATE (eva(ros%nreg,MyNEofs)); eva = huge(eva(1,1))
+ ALLOCATE (evc(ros%nreg,my_km,MyNEofs)); evc = huge(evc(1,1,1))
+
+ if((drv%chl_assim .eq.1) .and. (drv%multiv .eq. 0)) then
+ eva(:,:) = ros%eva_chl(:,:)
+ evc(:,:,:) = ros%evc_chl(:,:,:)
+ else if((drv%chl_assim .eq.0) .and. (drv%multiv .eq. 1)) then
+ eva(:,:) = ros%eva_multi(:,:)
+ evc(:,1:my_km,:) = ros%evc_multi(:,1:my_km,:)
+ endif
grd%chl(:,:,:) = 0.0
!cdir noconcur
- do n=1,ros%neof
+ do n=1,MyNEofs
egm(:,:) = 0.0
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
+ egm(i,j) = eva(grd%reg(i,j),n) * grd%ro( i, j, n)
enddo
enddo
! 3D variables
- do k=1,grd%km ! OMP
- k1 = k1 + 1
+ do k=1,my_km ! OMP
do j=1,grd%jm
- do i=1,grd%im
-#ifdef opt_huge_memory
- grd%chl(i,j,k) = grd%chl(i,j,k) + ros%evc( i, j, k1, n) * egm(i,j)
-#else
- grd%chl(i,j,k) = grd%chl(i,j,k) + ros%evc(grd%reg(i,j),k,n) * egm(i,j)
-#endif
- enddo
+ do i=1,grd%im
+ grd%chl(i,j,k) = grd%chl(i,j,k) + evc(grd%reg(i,j),k,n) * egm(i,j)
+ enddo
enddo
enddo
enddo
+
+ DEALLOCATE(eva,evc)
-end subroutine veof
+end subroutine veof_chl
diff --git a/veof_chl_ad.f90 b/veof_chl_ad.f90
new file mode 100644
index 0000000..6f1d8b0
--- /dev/null
+++ b/veof_chl_ad.f90
@@ -0,0 +1,126 @@
+subroutine veof_chl_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
+ use mpi_str
+
+ implicit none
+
+ INTEGER(i4) :: i, j, k, l, n, my_km, MyNEofs, ierr!, k1
+ REAL(r8), DIMENSION ( grd%im, grd%jm) :: egm
+ REAL(r8), ALLOCATABLE, DIMENSION(:,:) :: eva
+ REAL(r8), ALLOCATABLE, DIMENSION(:,:,:) :: evc
+
+my_km = 0
+if((drv%chl_assim .eq.1) .and. (drv%multiv .eq. 0)) then
+ MyNEofs = ros%neof_chl
+ my_km = grd%km
+else if((drv%chl_assim .eq.0) .and. (drv%multiv .eq. 1)) then
+ MyNEofs = ros%neof_multi
+ my_km = ros%kmchl
+endif
+
+if(my_km .eq. 0) then
+ if(MyId .eq. 0) then
+ write(drv%dia,*) "Error! my_km for chlorophyll not setted"
+ write(drv%dia,*) "chl_assim e multiv flags should be alternatively valid"
+ write(drv%dia,*) ""
+ write(*,*) "Error! my_km for chlorophyll not setted! Aborting"
+ write(*,*) "chl_assim e multiv flags should be alternatively valid"
+ write(*,*) ""
+ endif
+ call MPI_Barrier(Var3DCommunicator, ierr)
+ call MPI_Abort(Var3DCommunicator,-1,ierr)
+endif
+
+ALLOCATE (eva(ros%nreg,MyNEofs)); eva = huge(eva(1,1))
+ALLOCATE (evc(ros%nreg,my_km,MyNEofs)); evc = huge(evc(1,1,1))
+
+if((drv%chl_assim .eq.1) .and. (drv%multiv .eq. 0)) then
+ eva(:,:) = ros%eva_chl(:,:)
+ evc(:,:,:) = ros%evc_chl(:,:,:)
+else if((drv%chl_assim .eq.0) .and. (drv%multiv .eq. 1)) then
+ eva(:,:) = ros%eva_multi(:,:)
+ evc(:,1:my_km,:) = ros%evc_multi(:,1:my_km,:)
+endif
+
+do n=1,MyNEofs
+ grd%ro_ad(:,:,n) = 0.0 ! OMP
+enddo
+
+!$OMP PARALLEL &
+!$OMP PRIVATE(i,j,k,k1,n) &
+!$OMP PRIVATE(egm)
+!$OMP DO
+ do n=1,MyNEofs
+
+ egm(:,:) = 0.0
+
+ ! 3D variables
+ ! k1 = 0
+
+ do k=1,my_km ! OMP
+ ! k1 = k1 + 1
+ do j=1,grd%jm
+ do i=1,grd%im
+ egm(i,j) = egm(i,j) + evc(grd%reg(i,j), k,n) * grd%chl_ad(i,j,k)
+ enddo
+ enddo
+ enddo
+
+
+ do j=1,grd%jm
+ do i=1,grd%im
+ egm(i,j) = eva(grd%reg(i,j),n) * egm(i,j)
+ enddo
+ enddo
+
+ !cdir serial
+ ! 3D variables
+ ! do l=n,ros%neof
+ do j=1,grd%jm
+ do i=1,grd%im
+ grd%ro_ad(i,j,n) = grd%ro_ad(i,j,n) + egm(i,j)
+ enddo
+ enddo
+ ! enddo
+ !cdir end serial
+
+enddo
+!$OMP END DO
+!$OMP END PARALLEL
+
+DEALLOCATE(eva,evc)
+
+end subroutine veof_chl_ad
diff --git a/veof_ad.f90 b/veof_multiv_ad.f90
similarity index 71%
rename from veof_ad.f90
rename to veof_multiv_ad.f90
index 43f8310..7e8f802 100644
--- a/veof_ad.f90
+++ b/veof_multiv_ad.f90
@@ -1,4 +1,4 @@
-subroutine veof_ad
+subroutine veof_multiv_ad
!---------------------------------------------------------------------------
! !
@@ -33,67 +33,66 @@ subroutine veof_ad
use drv_str
use grd_str
use eof_str
+ use mpi_str
implicit none
- INTEGER(i4) :: i, j, k, l, n, k1
+ INTEGER(i4) :: i, j, k, l, n, my_km !, k1
REAL(r8), DIMENSION ( grd%im, grd%jm) :: egm
- grd%ro_ad(:,:,:) = 0.0 ! OMP
+my_km = ros%kmchl
+
+
+do n=1,ros%neof_multi
+ grd%ro_ad(:,:,n) = 0.0 ! OMP
+enddo
!$OMP PARALLEL &
!$OMP PRIVATE(i,j,k,k1,n) &
!$OMP PRIVATE(egm)
!$OMP DO
- do n=1,ros%neof
+do n=1,ros%neof_multi
- egm(:,:) = 0.0
+ egm(:,:) = 0.0
! 3D variables
- k1 = 0
-
- 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)
-#else
- egm(i,j) = egm(i,j) + ros%evc(grd%reg(i,j), k,n) * grd%chl_ad(i,j,k)
-#endif
- enddo
- enddo
- enddo
-
+ ! k1 = 0
- do j=1,grd%jm
+ 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) = ros%eva( i, j, n) * egm(i,j)
-#else
- egm(i,j) = ros%eva(grd%reg(i,j),n) * egm(i,j)
-#endif
+ if(k.le.my_km) then
+ egm(i,j) = egm(i,j) + ros%evc_multi(grd%reg(i,j), k,n) * grd%chl_ad(i,j,k)
+
+ endif
+ egm(i,j) = egm(i,j) + ros%evc_multi(grd%reg(i,j),k+my_km,n) * grd%n3n_ad(i,j,k)
enddo
- enddo
+ enddo
+ enddo
+
+
+
+ do j=1,grd%jm
+ do i=1,grd%im
+ egm(i,j) = ros%eva_multi(grd%reg(i,j),n) * egm(i,j)
+ 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
+ do j=1,grd%jm
+ do i=1,grd%im
+ grd%ro_ad(i,j,n) = grd%ro_ad(i,j,n) + egm(i,j)
+ enddo
+ enddo
! enddo
!cdir end serial
enddo
!$OMP END DO
-!$OMP END PARALLEL
+!$OMP END PARALLEL
-end subroutine veof_ad
+end subroutine veof_multiv_ad
diff --git a/veof_nut.f90 b/veof_nut.f90
new file mode 100644
index 0000000..49fe217
--- /dev/null
+++ b/veof_nut.f90
@@ -0,0 +1,131 @@
+subroutine veof_nut(NutArray, Var)
+!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
+ use mpi_str
+
+ implicit none
+
+ INTEGER(i4) :: i, j, k, l,n, my_km, ierr
+ REAL(r8), DIMENSION ( grd%im, grd%jm) :: egm
+ REAL(r8) :: NutArray(grd%im,grd%jm,grd%km)
+ REAL(r8), ALLOCATABLE, DIMENSION(:,:) :: eva
+ REAL(r8), ALLOCATABLE, DIMENSION(:,:,:) :: evc
+ INTEGER(I4) :: MyNEofs, offset
+ CHARACTER :: Var
+
+ NutArray(:,:,:) = 0.0
+
+ my_km = 0
+ offset = 0
+ if((drv%nut .eq.1) .and. (drv%multiv .eq. 0)) then
+ my_km = grd%km
+ if(Var .eq. 'N') then
+ MyNEofs = ros%neof_n3n
+ offset = ros%neof_chl
+ else
+ MyNEofs = ros%neof_o2o
+ offset = ros%neof_chl + ros%neof_n3n
+ endif
+ else if((drv%nut .eq.0) .and. (drv%multiv .eq. 1)) then
+ if(Var .eq. 'N') then
+ my_km = grd%km
+ MyNEofs = ros%neof_multi
+ else
+ if(MyId .eq. 0) then
+ write(drv%dia,*) "Error! Only nitrate multivariate assimilation implemented"
+ write(drv%dia,*) ""
+ write(*,*) "Error! Only nitrate multivariate assimilation implemented! Aborting"
+ write(*,*) ""
+ endif
+ call MPI_Barrier(Var3DCommunicator, ierr)
+ call MPI_Abort(Var3DCommunicator,-1,ierr)
+ endif
+ endif
+
+
+ if(my_km .eq. 0) then
+ if(MyId .eq. 0) then
+ write(drv%dia,*) "Error! my_km for nutrient not setted"
+ write(drv%dia,*) "drv%nut e multiv flags should be alternatively valid"
+ write(drv%dia,*) ""
+ write(*,*) "Error! my_km for nutrient not setted! Aborting"
+ write(*,*) "drv%nut e multiv flags should be alternatively valid"
+ write(*,*) ""
+ endif
+ call MPI_Barrier(Var3DCommunicator, ierr)
+ call MPI_Abort(Var3DCommunicator,-1,ierr)
+ endif
+
+ ALLOCATE (eva(ros%nreg,MyNEofs)); eva = huge(eva(1,1))
+ ALLOCATE (evc(ros%nreg,my_km,MyNEofs)); evc = huge(evc(1,1,1))
+
+ if((drv%nut .eq.1) .and. (drv%multiv .eq. 0)) then
+ if(Var .eq. 'N') then
+ eva = ros%eva_n3n
+ evc = ros%evc_n3n
+ else
+ eva = ros%eva_o2o
+ evc = ros%evc_o2o
+ endif
+ else if((drv%nut .eq.0) .and. (drv%multiv .eq. 1)) then
+ if(Var .eq. 'N') then
+ eva = ros%eva_multi
+ evc(:,1:my_km,:) = ros%evc_multi(:,ros%kmchl+1:ros%kmchl+grd%km,:)
+ endif
+ endif
+
+ !cdir noconcur
+ do n=1,MyNEofs
+
+ egm(:,:) = 0.0
+
+ do j=1,grd%jm
+ do i=1,grd%im
+ egm(i,j) = eva(grd%reg(i,j),n) * grd%ro( i, j, n+offset)
+ enddo
+ enddo
+
+ ! 3D variables
+ do k=1,my_km ! OMP
+ do j=1,grd%jm
+ do i=1,grd%im
+ NutArray(i,j,k) = NutArray(i,j,k) + evc(grd%reg(i,j),k,n) * egm(i,j)
+ enddo
+ enddo
+ enddo
+ enddo
+
+DEALLOCATE(eva,evc)
+end subroutine veof_nut
diff --git a/veof_nut_ad.f90 b/veof_nut_ad.f90
new file mode 100644
index 0000000..858a8a5
--- /dev/null
+++ b/veof_nut_ad.f90
@@ -0,0 +1,127 @@
+subroutine veof_nut_ad(NutArrayAd, Var)
+
+!---------------------------------------------------------------------------
+! !
+! 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, offset, my_km
+ REAL(r8), DIMENSION ( grd%im, grd%jm) :: egm
+ REAL(r8) :: NutArrayAd(grd%im,grd%jm,grd%km)
+ REAL(r8), ALLOCATABLE, DIMENSION(:,:) :: eva
+ REAL(r8), ALLOCATABLE, DIMENSION(:,:,:) :: evc
+ CHARACTER :: Var
+ INTEGER :: MyNEofs
+
+ my_km = 0
+ ! Altrove usato grd%km come limite per assimilazione nit qui ro%kmnit
+ ! Da correggere o fare un check
+ offset = 0
+ if((drv%nut .eq.1) .and. (drv%multiv .eq. 0)) then
+ my_km = grd%km
+ if(Var .eq. 'N') then
+ MyNEofs = ros%neof_n3n
+ offset = ros%neof_chl
+ else
+ MyNEofs = ros%neof_o2o
+ offset = ros%neof_chl + ros%neof_n3n
+ endif
+ else if((drv%nut .eq.0) .and. (drv%multiv .eq. 1)) then
+ if(Var .eq. 'N') then
+ my_km = ros%kmnit
+ MyNEofs = ros%neof_multi
+ endif
+ endif
+
+
+ ALLOCATE (eva(ros%nreg,MyNEofs)); eva = huge(eva(1,1))
+ ALLOCATE (evc(ros%nreg,my_km,MyNEofs)); evc = huge(evc(1,1,1))
+
+ if((drv%nut .eq.1) .and. (drv%multiv .eq. 0)) then
+ if(Var .eq. 'N') then
+ eva = ros%eva_n3n
+ evc = ros%evc_n3n
+ else
+ eva = ros%eva_o2o
+ evc = ros%evc_o2o
+ endif
+ else if((drv%nut .eq.0) .and. (drv%multiv .eq. 1)) then
+ if(Var .eq. 'N') then
+ eva = ros%eva_multi
+ evc(:,1:my_km,:) = ros%evc_multi(:,ros%kmchl+1:ros%kmchl+ros%kmnit,:)
+ endif
+ endif
+
+ do n=1,MyNEofs
+ grd%ro_ad(:,:,n+offset) = 0.0 ! OMP
+ enddo
+
+!$OMP PARALLEL &
+!$OMP PRIVATE(i,j,k,k1,n) &
+!$OMP PRIVATE(egm)
+!$OMP DO
+ do n=1,MyNEofs
+
+ egm(:,:) = 0.0
+
+ ! 3D variables
+
+ do k=1,my_km ! OMP
+ do j=1,grd%jm
+ do i=1,grd%im
+ egm(i,j) = egm(i,j) + evc(grd%reg(i,j), k,n) * NutArrayAd(i,j,k)
+ enddo
+ enddo
+ enddo
+
+
+ do j=1,grd%jm
+ do i=1,grd%im
+ egm(i,j) = eva(grd%reg(i,j),n) * egm(i,j)
+ enddo
+ enddo
+
+ do j=1,grd%jm
+ do i=1,grd%im
+ grd%ro_ad(i,j,n+offset) = grd%ro_ad(i,j,n+offset) + egm(i,j)
+ enddo
+ enddo
+
+enddo
+!$OMP END DO
+!$OMP END PARALLEL
+
+DEALLOCATE(eva,evc)
+
+end subroutine veof_nut_ad
diff --git a/ver_hor_chl.f90 b/ver_hor_chl.f90
new file mode 100644
index 0000000..6ed94b5
--- /dev/null
+++ b/ver_hor_chl.f90
@@ -0,0 +1,262 @@
+subroutine ver_hor_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 . !
+ ! !
+ !---------------------------------------------------------------------------
+
+ !-----------------------------------------------------------------------
+ ! !
+ ! 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
+ use mpi_str
+
+ implicit none
+
+ INTEGER(i4) :: i,j,k, ione, l, my_km, myimax, myjmax
+ INTEGER :: jp, SurfaceIndex, TmpOffset, LinearIndex
+ INTEGER(i4) :: iProc, ierr
+ type(DoubleGrid), allocatable, dimension(:,:,:) :: SendBuf3D
+ type(DoubleGrid), allocatable, dimension(:) :: RecBuf1D(:)
+ REAL(r8), allocatable, dimension(:,:,:) :: DefBufChl, DefBufChlAd
+
+ ione = 1
+
+ ! ---
+ ! Vertical EOFs
+ call veof_chl
+ !return
+ ! goto 103 !No Vh
+
+ my_km = grd%km
+ myimax = grd%imax
+ myjmax = grd%jmax
+ if(drv%multiv.eq.1) then
+ my_km = ros%kmchl
+ myimax = grd%imax_chl
+ myjmax = grd%jmax_chl
+ endif
+ ! ---
+ ! Load temporary arrays
+ do k=1,my_km
+ grd%chl_ad(:,:,k) = grd%chl(:,:,k)
+ enddo
+
+ !********** APPLY RECURSIVE FILTERS ********** !
+ ! ---
+ ! Transpose calculation in the presense of coastal boundaries
+
+ ! ---
+ ! y direction
+ ! ---
+ ! Scale by the scaling factor
+ do k=1,my_km
+ grd%chl_ad(:,:,k) = grd%chl_ad(:,:,k) * grd%scy(:,:,k)
+ enddo
+
+ ! Apply recursive filter in y direction
+ call rcfl_y_ad( localRow, GlobalCol, my_km, myjmax, grd%aey(:,:,1:my_km), &
+ grd%bey(:,:,1:my_km), grd%chl_ad, grd%jnx(:,:,1:my_km), grd%jmx(1:my_km))
+ ! ---
+ ! x direction
+ if(NumProcI .gt. 1) then
+ ALLOCATE(SendBuf3D(my_km, grd%im, grd%jm))
+ ALLOCATE( RecBuf1D(my_km*GlobalRow*localCol))
+ ALLOCATE( DefBufChl(GlobalRow, localCol, my_km))
+ ALLOCATE( DefBufChlAd(GlobalRow, localCol, my_km))
+
+ do k=1,my_km
+ do j=1,grd%jm
+ do i=1,grd%im
+ SendBuf3D(k,i,j)%chl = grd%chl(i,j,k)
+ end do
+ end do
+ end do
+ do k=1,my_km
+ do j=1,grd%jm
+ do i=1,grd%im
+ SendBuf3D(k,i,j)%chl_ad = grd%chl_ad(i,j,k)
+ end do
+ end do
+ end do
+
+ call MPI_Alltoallv(SendBuf3D, SendCountX3D_chl, SendDisplX3D_chl, MyPair, &
+ RecBuf1D, RecCountX3D_chl, RecDisplX3D_chl, MyPair, Var3DCommunicator, ierr)
+
+ SurfaceIndex = localCol*my_km
+ do j=1,localCol
+ do iProc=0, NumProcI-1
+ TmpOffset = RecDisplX3D_chl(iProc+1)/SurfaceIndex
+ do i=1,RecCountX3D_chl(iProc+1)/SurfaceIndex
+ LinearIndex = (i-1)*my_km + (j-1)*RecCountX3D_chl(iProc+1)/localCol + RecDisplX3D_chl(iProc+1)
+ do k=1,my_km
+ DefBufChl(i + TmpOffset,j,k) = RecBuf1D(k + LinearIndex)%chl
+ end do
+ end do
+
+ end do
+ end do
+ do j=1,localCol
+ do iProc=0, NumProcI-1
+ TmpOffset = RecDisplX3D_chl(iProc+1)/SurfaceIndex
+ do i=1,RecCountX3D_chl(iProc+1)/SurfaceIndex
+ LinearIndex = (i-1)*my_km + (j-1)*RecCountX3D_chl(iProc+1)/localCol + RecDisplX3D_chl(iProc+1)
+ do k=1,my_km
+ DefBufChlAd(i + TmpOffset,j,k) = RecBuf1D(k + LinearIndex)%chl_ad
+ end do
+ end do
+ end do
+ end do
+
+ ! ---
+ ! Scale by the scaling factor
+ do k=1,my_km
+ DefBufChlAd(:,:,k) = DefBufChlAd(:,:,k) * grd%scx(:,:,k)
+ enddo
+
+ call rcfl_x_ad( GlobalRow, localCol, my_km, myimax, grd%aex(:,:,1:my_km), &
+ grd%bex(:,:,1:my_km), DefBufChlAd, grd%inx(:,:,1:my_km), grd%imx(1:my_km))
+
+ else
+ ! ---
+ ! Scale by the scaling factor
+ do k=1,my_km
+ grd%chl_ad(:,:,k) = grd%chl_ad(:,:,k) * grd%scx(:,:,k)
+ enddo
+
+ call rcfl_x_ad( GlobalRow, localCol, my_km, myimax, grd%aex(:,:,1:my_km), &
+ grd%bex(:,:,1:my_km), grd%chl_ad, grd%inx(:,:,1:my_km), grd%imx(1:my_km))
+
+ end if
+
+
+
+ ! ---
+ ! x direction
+ if(NumProcI .gt. 1) then
+
+ call rcfl_x( GlobalRow, localCol, my_km, myimax, grd%aex(:,:,1:my_km), &
+ grd%bex(:,:,1:my_km), DefBufChl, grd%inx(:,:,1:my_km), grd%imx(1:my_km))
+
+ do k=1,my_km
+ DefBufChl(:,:,k) = DefBufChl(:,:,k) * grd%scx(:,:,k)
+ enddo
+
+ ! Reordering data to send back
+ DEALLOCATE(SendBuf3D, RecBuf1D)
+ ALLOCATE(SendBuf3D(my_km, localCol, GlobalRow))
+ ALLOCATE( RecBuf1D(my_km*grd%jm*grd%im))
+
+ do k=1,my_km
+ do j=1,localCol
+ do i=1,GlobalRow
+ SendBuf3D(k,j,i)%chl = DefBufChl(i,j,k)
+ end do
+ end do
+ end do
+ do k=1,my_km
+ do j=1,localCol
+ do i=1,GlobalRow
+ SendBuf3D(k,j,i)%chl_ad = DefBufChlAd(i,j,k)
+ end do
+ end do
+ end do
+
+ call MPI_Alltoallv(SendBuf3D, RecCountX3D_chl, RecDisplX3D_chl, MyPair, &
+ RecBuf1D, SendCountX3D_chl, SendDisplX3D_chl, MyPair, Var3DCommunicator, ierr)
+
+ SurfaceIndex = grd%im*my_km
+ do i=1,grd%im
+ do iProc=0, NumProcI-1
+ TmpOffset = SendDisplX3D_chl(iProc+1)/SurfaceIndex
+ do j=1,SendCountX3D_chl(iProc+1)/SurfaceIndex
+ LinearIndex = (j-1)*my_km +(i-1)*SendCountX3D_chl(iProc+1)/grd%im + SendDisplX3D_chl(iProc+1)
+ do k=1,my_km
+ grd%chl(i, j + TmpOffset,k) = RecBuf1D(k + LinearIndex)%chl
+ end do
+ end do
+ end do
+ end do
+ do i=1,grd%im
+ do iProc=0, NumProcI-1
+ TmpOffset = SendDisplX3D_chl(iProc+1)/SurfaceIndex
+ do j=1,SendCountX3D_chl(iProc+1)/SurfaceIndex
+ LinearIndex = (j-1)*my_km +(i-1)*SendCountX3D_chl(iProc+1)/grd%im + SendDisplX3D_chl(iProc+1)
+ do k=1,my_km
+ grd%chl_ad(i, j + TmpOffset,k) = RecBuf1D(k + LinearIndex)%chl_ad
+ end do
+ end do
+ end do
+ end do
+
+ DEALLOCATE(SendBuf3D, RecBuf1D, DefBufChl, DefBufChlAd)
+
+ else ! NumProcI .eq. 1
+
+ call rcfl_x( GlobalRow, localCol, my_km, myimax, grd%aex(:,:,1:my_km), &
+ grd%bex(:,:,1:my_km), grd%chl, grd%inx(:,:,1:my_km), grd%imx(1:my_km))
+
+ do k=1,my_km
+ grd%chl(:,:,k) = grd%chl(:,:,k) * grd%scx(:,:,k)
+ enddo
+
+ end if
+
+ ! ---
+ ! y direction
+ ! Apply recursive filter in y direction
+ call rcfl_y( localRow, GlobalCol, my_km, myjmax, grd%aey(:,:,1:my_km), &
+ grd%bey(:,:,1:my_km), grd%chl, grd%jnx(:,:,1:my_km), grd%jmx(1:my_km))
+
+ ! ---
+ ! Scale by the scaling factor
+ do k=1,my_km
+ grd%chl(:,:,k) = grd%chl(:,:,k) * grd%scy(:,:,k)
+ enddo
+
+ ! ---
+ ! Average
+ do k=1,my_km
+ grd%chl(:,:,k) = (grd%chl(:,:,k) + grd%chl_ad(:,:,k) ) * 0.5
+ enddo
+
+ ! ---
+ ! Scale for boundaries
+ do k=1,my_km
+ grd%chl(:,:,k) = grd%chl(:,:,k) * grd%msk(:,:,k)
+ enddo
+
+ ! 103 continue
+
+end subroutine ver_hor_chl
diff --git a/ver_hor_chl_ad.f90 b/ver_hor_chl_ad.f90
new file mode 100644
index 0000000..6205412
--- /dev/null
+++ b/ver_hor_chl_ad.f90
@@ -0,0 +1,241 @@
+subroutine ver_hor_chl_ad
+
+ !-----------------------------------------------------------------------
+ ! !
+ ! 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
+ use mpi_str
+
+ implicit none
+
+ INTEGER(i4) :: i,j,k, ione, l, my_km, myimax, myjmax
+ INTEGER :: jp, SurfaceIndex, TmpOffset, LinearIndex
+ INTEGER(i4) :: iProc, ierr
+ type(DoubleGrid), allocatable, dimension(:,:,:) :: SendBuf3D
+ type(DoubleGrid), allocatable, dimension(:) :: RecBuf1D
+ REAL(r8), allocatable, dimension(:,:,:) :: DefBufChl, DefBufChlAd
+
+ ione = 1
+
+ ! goto 103 ! No Vh
+
+ my_km = grd%km
+ myimax = grd%imax
+ myjmax = grd%jmax
+ if(drv%multiv.eq.1) then
+ my_km = ros%kmchl
+ myimax = grd%imax_chl
+ myjmax = grd%jmax_chl
+ endif
+ ! ---
+ ! Scale for boundaries
+ do k=1,my_km
+ grd%chl_ad(:,:,k) = grd%chl_ad(:,:,k) * grd%msk(:,:,k)
+ enddo
+
+
+ ! ---
+ ! Load temporary arrays
+ do k=1,my_km
+ grd%chl(:,:,k) = grd%chl_ad(:,:,k)
+ enddo
+
+ ! ---
+ ! y direction
+ ! ---
+ ! Scale by the scaling factor
+ do k=1,my_km
+ grd%chl_ad(:,:,k) = grd%chl_ad(:,:,k) * grd%scy(:,:,k)
+ enddo
+
+ ! Apply recursive filter in y direction
+ call rcfl_y_ad( localRow, GlobalCol, my_km, myjmax, grd%aey(:,:,1:my_km), &
+ grd%bey(:,:,1:my_km), grd%chl_ad, grd%jnx(:,:,1:my_km), grd%jmx(1:my_km))
+
+ ! ---
+ ! x direction
+ if(NumProcI .gt. 1) then
+ ALLOCATE(SendBuf3D(my_km, grd%im, grd%jm))
+ ALLOCATE( RecBuf1D(my_km*localCol*GlobalRow))
+ ALLOCATE(DefBufChl(GlobalRow, localCol, my_km))
+ ALLOCATE(DefBufChlAd(GlobalRow, localCol, my_km))
+
+ do k=1,my_km
+ do j=1,grd%jm
+ do i=1,grd%im
+ SendBuf3D(k,i,j)%chl = grd%chl(i,j,k)
+ end do
+ end do
+ end do
+ do k=1,my_km
+ do j=1,grd%jm
+ do i=1,grd%im
+ SendBuf3D(k,i,j)%chl_ad = grd%chl_ad(i,j,k)
+ end do
+ end do
+ end do
+
+ call MPI_Alltoallv(SendBuf3D, SendCountX3D_chl, SendDisplX3D_chl, MyPair, &
+ RecBuf1D, RecCountX3D_chl, RecDisplX3D_chl, MyPair, Var3DCommunicator, ierr)
+
+ SurfaceIndex = localCol*my_km
+ do j=1,localCol
+ do iProc=0, NumProcI-1
+ TmpOffset = RecDisplX3D_chl(iProc+1)/SurfaceIndex
+ do i=1,RecCountX3D_chl(iProc+1)/SurfaceIndex
+ LinearIndex = (i-1)*my_km + (j-1)*RecCountX3D_chl(iProc+1)/localCol + RecDisplX3D_chl(iProc+1)
+ do k=1,my_km
+ DefBufChl(i + TmpOffset,j,k) = RecBuf1D(k + LinearIndex)%chl
+ end do
+ end do
+ end do
+ end do
+ do j=1,localCol
+ do iProc=0, NumProcI-1
+ TmpOffset = RecDisplX3D_chl(iProc+1)/SurfaceIndex
+ do i=1,RecCountX3D_chl(iProc+1)/SurfaceIndex
+ LinearIndex = (i-1)*my_km + (j-1)*RecCountX3D_chl(iProc+1)/localCol + RecDisplX3D_chl(iProc+1)
+ do k=1,my_km
+ DefBufChlAd(i + TmpOffset,j,k) = RecBuf1D(k + LinearIndex)%chl_ad
+ end do
+ end do
+ end do
+ end do
+
+ ! ---
+ ! Scale by the scaling factor
+ do k=1,my_km
+ DefBufChlAd(:,:,k) = DefBufChlAd(:,:,k) * grd%scx(:,:,k)
+ enddo
+
+ call rcfl_x_ad( GlobalRow, localCol, my_km, myimax, grd%aex(:,:,1:my_km), &
+ grd%bex(:,:,1:my_km), DefBufChlAd, grd%inx(:,:,1:my_km), grd%imx(1:my_km))
+
+ else ! NumProcI .eq. 1
+ ! ---
+ ! Scale by the scaling factor
+ do k=1,my_km
+ grd%chl_ad(:,:,k) = grd%chl_ad(:,:,k) * grd%scx(:,:,k)
+ enddo
+
+ call rcfl_x_ad( GlobalRow, localCol, my_km, myimax, grd%aex(:,:,1:my_km), &
+ grd%bex(:,:,1:my_km), grd%chl_ad, grd%inx(:,:,1:my_km), grd%imx(1:my_km))
+ end if
+
+
+ ! ---
+ ! x direction
+ if(NumProcI .gt. 1) then
+
+ call rcfl_x( GlobalRow, localCol, my_km, myimax, grd%aex(:,:,1:my_km), &
+ grd%bex(:,:,1:my_km), DefBufChl, grd%inx(:,:,1:my_km), grd%imx(1:my_km))
+
+ ! ---
+ ! Scale by the scaling factor
+ do k=1,my_km
+ DefBufChl(:,:,k) = DefBufChl(:,:,k) * grd%scx(:,:,k)
+ enddo
+
+ ! Reordering data to send back
+ DEALLOCATE(SendBuf3D, RecBuf1D)
+ ALLOCATE(SendBuf3D(my_km, localCol, GlobalRow))
+ ALLOCATE( RecBuf1D(my_km*grd%jm*grd%im))
+
+ do k=1,my_km
+ do j=1,localCol
+ do i=1,GlobalRow
+ SendBuf3D(k,j,i)%chl = DefBufChl(i,j,k)
+ end do
+ end do
+ end do
+ do k=1,my_km
+ do j=1,localCol
+ do i=1,GlobalRow
+ SendBuf3D(k,j,i)%chl_ad = DefBufChlAd(i,j,k)
+ end do
+ end do
+ end do
+
+ call MPI_Alltoallv(SendBuf3D, RecCountX3D_chl, RecDisplX3D_chl, MyPair, &
+ RecBuf1D, SendCountX3D_chl, SendDisplX3D_chl, MyPair, Var3DCommunicator, ierr)
+
+ SurfaceIndex = grd%im*my_km
+ do i=1,grd%im
+ do iProc=0, NumProcI-1
+ TmpOffset = SendDisplX3D_chl(iProc+1)/SurfaceIndex
+ do j=1,SendCountX3D_chl(iProc+1)/SurfaceIndex
+ LinearIndex = (j-1)*my_km +(i-1)*SendCountX3D_chl(iProc+1)/grd%im + SendDisplX3D_chl(iProc+1)
+ do k=1,my_km
+ grd%chl(i, j + TmpOffset,k) = RecBuf1D(k + LinearIndex)%chl
+ end do
+ end do
+ end do
+ end do
+ do i=1,grd%im
+ do iProc=0, NumProcI-1
+ TmpOffset = SendDisplX3D_chl(iProc+1)/SurfaceIndex
+ do j=1,SendCountX3D_chl(iProc+1)/SurfaceIndex
+ LinearIndex = (j-1)*my_km +(i-1)*SendCountX3D_chl(iProc+1)/grd%im + SendDisplX3D_chl(iProc+1)
+ do k=1,my_km
+ grd%chl_ad(i, j + TmpOffset,k) = RecBuf1D(k + LinearIndex)%chl_ad
+ end do
+ end do
+ end do
+ end do
+
+ DEALLOCATE(SendBuf3D, RecBuf1D, DefBufChl, DefBufChlAd)
+
+ else ! NumProcI .eq. 1
+ call rcfl_x( GlobalRow, localCol, my_km, myimax, grd%aex(:,:,1:my_km), &
+ grd%bex(:,:,1:my_km), grd%chl, grd%inx(:,:,1:my_km), grd%imx(1:my_km))
+
+ ! ---
+ ! Scale by the scaling factor
+ do k=1,my_km
+ grd%chl(:,:,k) = grd%chl(:,:,k) * grd%scx(:,:,k)
+ enddo
+ end if
+
+
+ ! ! ---
+ ! ! y direction
+ ! Apply recursive filter in y direction
+ call rcfl_y( localRow, GlobalCol, my_km, myjmax, grd%aey(:,:,1:my_km), &
+ grd%bey(:,:,1:my_km), grd%chl, grd%jnx(:,:,1:my_km), grd%jmx(1:my_km))
+
+ ! ---
+ ! Scale by the scaling factor
+ do k=1,my_km
+ grd%chl(:,:,k) = grd%chl(:,:,k) * grd%scy(:,:,k)
+ enddo
+
+
+ ! ---
+ ! Average
+ do k=1,my_km
+ grd%chl_ad(:,:,k) = (grd%chl_ad(:,:,k) + grd%chl(:,:,k) ) * 0.5
+ enddo
+
+
+ ! 103 continue
+ ! ---
+ ! Vertical EOFs
+ if(drv%multiv.eq.0) &
+ call veof_chl_ad
+
+end subroutine ver_hor_chl_ad
diff --git a/ver_hor.f90 b/ver_hor_nut.f90
similarity index 88%
rename from ver_hor.f90
rename to ver_hor_nut.f90
index 77445d3..be99ae2 100644
--- a/ver_hor.f90
+++ b/ver_hor_nut.f90
@@ -1,4 +1,4 @@
-subroutine ver_hor
+subroutine ver_hor_nut(NutArray, NutArrayAd, Var)
!---------------------------------------------------------------------------
! !
@@ -50,19 +50,21 @@ subroutine ver_hor
type(DoubleGrid), allocatable, dimension(:,:,:) :: SendBuf3D
type(DoubleGrid), allocatable, dimension(:) :: RecBuf1D(:)
REAL(r8), allocatable, dimension(:,:,:) :: DefBufChl, DefBufChlAd
+ REAL(r8) :: NutArray(grd%im,grd%jm,grd%km), NutArrayAd(grd%im,grd%jm,grd%km)
+ CHARACTER :: Var
ione = 1
! ---
! Vertical EOFs
- call veof
+ call veof_nut(NutArray, Var)
!return
! goto 103 !No Vh
! ---
! Load temporary arrays
do k=1,grd%km
- grd%chl_ad(:,:,k) = grd%chl(:,:,k)
+ NutArrayAd(:,:,k) = NutArray(:,:,k)
enddo
!********** APPLY RECURSIVE FILTERS ********** !
@@ -74,11 +76,11 @@ subroutine ver_hor
! ---
! Scale by the scaling factor
do k=1,grd%km
- grd%chl_ad(:,:,k) = grd%chl_ad(:,:,k) * grd%scy(:,:,k)
+ NutArrayAd(:,:,k) = NutArrayAd(:,:,k) * grd%scy(:,:,k)
enddo
! Apply recursive filter in y direction
- call rcfl_y_ad( localRow, GlobalCol, grd%km, grd%jmax, grd%aey, grd%bey, grd%chl_ad, grd%jnx, grd%jmx)
+ call rcfl_y_ad( localRow, GlobalCol, grd%km, grd%jmax, grd%aey, grd%bey, NutArrayAd, grd%jnx, grd%jmx)
! ---
! x direction
@@ -91,14 +93,14 @@ subroutine ver_hor
do k=1,grd%km
do j=1,grd%jm
do i=1,grd%im
- SendBuf3D(k,i,j)%chl = grd%chl(i,j,k)
+ SendBuf3D(k,i,j)%chl = NutArray(i,j,k)
end do
end do
end do
do k=1,grd%km
do j=1,grd%jm
do i=1,grd%im
- SendBuf3D(k,i,j)%chl_ad = grd%chl_ad(i,j,k)
+ SendBuf3D(k,i,j)%chl_ad = NutArrayAd(i,j,k)
end do
end do
end do
@@ -143,10 +145,10 @@ subroutine ver_hor
! ---
! Scale by the scaling factor
do k=1,grd%km
- grd%chl_ad(:,:,k) = grd%chl_ad(:,:,k) * grd%scx(:,:,k)
+ NutArrayAd(:,:,k) = NutArrayAd(:,:,k) * grd%scx(:,:,k)
enddo
- call rcfl_x_ad( GlobalRow, localCol, grd%km, grd%imax, grd%aex, grd%bex, grd%chl_ad, grd%inx, grd%imx)
+ call rcfl_x_ad( GlobalRow, localCol, grd%km, grd%imax, grd%aex, grd%bex, NutArrayAd, grd%inx, grd%imx)
end if
@@ -192,7 +194,7 @@ subroutine ver_hor
do j=1,SendCountX3D(iProc+1)/SurfaceIndex
LinearIndex = (j-1)*grd%km +(i-1)*SendCountX3D(iProc+1)/grd%im + SendDisplX3D(iProc+1)
do k=1,grd%km
- grd%chl(i, j + TmpOffset,k) = RecBuf1D(k + LinearIndex)%chl
+ NutArray(i, j + TmpOffset,k) = RecBuf1D(k + LinearIndex)%chl
end do
end do
end do
@@ -203,7 +205,7 @@ subroutine ver_hor
do j=1,SendCountX3D(iProc+1)/SurfaceIndex
LinearIndex = (j-1)*grd%km +(i-1)*SendCountX3D(iProc+1)/grd%im + SendDisplX3D(iProc+1)
do k=1,grd%km
- grd%chl_ad(i, j + TmpOffset,k) = RecBuf1D(k + LinearIndex)%chl_ad
+ NutArrayAd(i, j + TmpOffset,k) = RecBuf1D(k + LinearIndex)%chl_ad
end do
end do
end do
@@ -213,10 +215,10 @@ subroutine ver_hor
else ! NumProcI .eq. 1
- call rcfl_x( GlobalRow, localCol, grd%km, grd%imax, grd%aex, grd%bex, grd%chl, grd%inx, grd%imx)
+ call rcfl_x( GlobalRow, localCol, grd%km, grd%imax, grd%aex, grd%bex, NutArray, grd%inx, grd%imx)
do k=1,grd%km
- grd%chl(:,:,k) = grd%chl(:,:,k) * grd%scx(:,:,k)
+ NutArray(:,:,k) = NutArray(:,:,k) * grd%scx(:,:,k)
enddo
end if
@@ -224,31 +226,26 @@ subroutine ver_hor
! ---
! y direction
! Apply recursive filter in y direction
- call rcfl_y( localRow, GlobalCol, grd%km, grd%jmax, grd%aey, grd%bey, grd%chl, grd%jnx, grd%jmx)
+ call rcfl_y( localRow, GlobalCol, grd%km, grd%jmax, grd%aey, grd%bey, NutArray, grd%jnx, grd%jmx)
! ---
! Scale by the scaling factor
do k=1,grd%km
- grd%chl(:,:,k) = grd%chl(:,:,k) * grd%scy(:,:,k)
+ NutArray(:,:,k) = NutArray(:,:,k) * grd%scy(:,:,k)
enddo
! ---
! Average
do k=1,grd%km
- grd%chl(:,:,k) = (grd%chl(:,:,k) + grd%chl_ad(:,:,k) ) * 0.5
+ NutArray(:,:,k) = (NutArray(:,:,k) + NutArrayAd(:,:,k) ) * 0.5
enddo
! ---
! Scale for boundaries
do k=1,grd%km
- grd%chl(:,:,k) = grd%chl(:,:,k) * grd%msk(:,:,k)
+ NutArray(:,:,k) = NutArray(:,:,k) * grd%msk(:,:,k)
enddo
! 103 continue
- ! ---
- ! Apply biological repartition of the chlorophyll
- if(drv%bio_assim .eq. 1) &
- call bio_mod
-
-end subroutine ver_hor
+end subroutine ver_hor_nut
diff --git a/ver_hor_ad.f90 b/ver_hor_nut_ad.f90
similarity index 84%
rename from ver_hor_ad.f90
rename to ver_hor_nut_ad.f90
index fbc1a80..8e02161 100644
--- a/ver_hor_ad.f90
+++ b/ver_hor_nut_ad.f90
@@ -1,4 +1,4 @@
-subroutine ver_hor_ad
+subroutine ver_hor_nut_ad(NutArray, NutArrayAd, Var)
!-----------------------------------------------------------------------
! !
@@ -29,25 +29,24 @@ subroutine ver_hor_ad
type(DoubleGrid), allocatable, dimension(:,:,:) :: SendBuf3D
type(DoubleGrid), allocatable, dimension(:) :: RecBuf1D
REAL(r8), allocatable, dimension(:,:,:) :: DefBufChl, DefBufChlAd
-
+ REAL(r8) :: NutArray(grd%im,grd%jm,grd%km), NutArrayAd(grd%im,grd%jm,grd%km)
+ CHARACTER :: Var
+
ione = 1
-
- if(drv%bio_assim .eq. 1) &
- call bio_mod_ad
-
+
! goto 103 ! No Vh
! ---
! Scale for boundaries
do k=1,grd%km
- grd%chl_ad(:,:,k) = grd%chl_ad(:,:,k) * grd%msk(:,:,k)
+ NutArrayAd(:,:,k) = NutArrayAd(:,:,k) * grd%msk(:,:,k)
enddo
! ---
! Load temporary arrays
do k=1,grd%km
- grd%chl(:,:,k) = grd%chl_ad(:,:,k)
+ NutArray(:,:,k) = NutArrayAd(:,:,k)
enddo
! ---
@@ -55,11 +54,11 @@ subroutine ver_hor_ad
! ---
! Scale by the scaling factor
do k=1,grd%km
- grd%chl_ad(:,:,k) = grd%chl_ad(:,:,k) * grd%scy(:,:,k)
+ NutArrayAd(:,:,k) = NutArrayAd(:,:,k) * grd%scy(:,:,k)
enddo
! Apply recursive filter in y direction
- call rcfl_y_ad( localRow, GlobalCol, grd%km, grd%jmax, grd%aey, grd%bey, grd%chl_ad, grd%jnx, grd%jmx)
+ call rcfl_y_ad( localRow, GlobalCol, grd%km, grd%jmax, grd%aey, grd%bey, NutArrayAd, grd%jnx, grd%jmx)
! ---
! x direction
@@ -72,14 +71,14 @@ subroutine ver_hor_ad
do k=1,grd%km
do j=1,grd%jm
do i=1,grd%im
- SendBuf3D(k,i,j)%chl = grd%chl(i,j,k)
+ SendBuf3D(k,i,j)%chl = NutArray(i,j,k)
end do
end do
end do
do k=1,grd%km
do j=1,grd%jm
do i=1,grd%im
- SendBuf3D(k,i,j)%chl_ad = grd%chl_ad(i,j,k)
+ SendBuf3D(k,i,j)%chl_ad = NutArrayAd(i,j,k)
end do
end do
end do
@@ -123,10 +122,10 @@ subroutine ver_hor_ad
! ---
! Scale by the scaling factor
do k=1,grd%km
- grd%chl_ad(:,:,k) = grd%chl_ad(:,:,k) * grd%scx(:,:,k)
+ NutArrayAd(:,:,k) = NutArrayAd(:,:,k) * grd%scx(:,:,k)
enddo
- call rcfl_x_ad( GlobalRow, localCol, grd%km, grd%imax, grd%aex, grd%bex, grd%chl_ad, grd%inx, grd%imx)
+ call rcfl_x_ad( GlobalRow, localCol, grd%km, grd%imax, grd%aex, grd%bex, NutArrayAd, grd%inx, grd%imx)
end if
@@ -172,7 +171,7 @@ subroutine ver_hor_ad
do j=1,SendCountX3D(iProc+1)/SurfaceIndex
LinearIndex = (j-1)*grd%km +(i-1)*SendCountX3D(iProc+1)/grd%im + SendDisplX3D(iProc+1)
do k=1,grd%km
- grd%chl(i, j + TmpOffset,k) = RecBuf1D(k + LinearIndex)%chl
+ NutArray(i, j + TmpOffset,k) = RecBuf1D(k + LinearIndex)%chl
end do
end do
end do
@@ -183,7 +182,7 @@ subroutine ver_hor_ad
do j=1,SendCountX3D(iProc+1)/SurfaceIndex
LinearIndex = (j-1)*grd%km +(i-1)*SendCountX3D(iProc+1)/grd%im + SendDisplX3D(iProc+1)
do k=1,grd%km
- grd%chl_ad(i, j + TmpOffset,k) = RecBuf1D(k + LinearIndex)%chl_ad
+ NutArrayAd(i, j + TmpOffset,k) = RecBuf1D(k + LinearIndex)%chl_ad
end do
end do
end do
@@ -192,12 +191,12 @@ subroutine ver_hor_ad
DEALLOCATE(SendBuf3D, RecBuf1D, DefBufChl, DefBufChlAd)
else ! NumProcI .eq. 1
- call rcfl_x( GlobalRow, localCol, grd%km, grd%imax, grd%aex, grd%bex, grd%chl, grd%inx, grd%imx)
+ call rcfl_x( GlobalRow, localCol, grd%km, grd%imax, grd%aex, grd%bex, NutArray, grd%inx, grd%imx)
! ---
! Scale by the scaling factor
do k=1,grd%km
- grd%chl(:,:,k) = grd%chl(:,:,k) * grd%scx(:,:,k)
+ NutArray(:,:,k) = NutArray(:,:,k) * grd%scx(:,:,k)
enddo
end if
@@ -205,25 +204,26 @@ subroutine ver_hor_ad
! ! ---
! ! y direction
! Apply recursive filter in y direction
- call rcfl_y( localRow, GlobalCol, grd%km, grd%jmax, grd%aey, grd%bey, grd%chl, grd%jnx, grd%jmx)
+ call rcfl_y( localRow, GlobalCol, grd%km, grd%jmax, grd%aey, grd%bey, NutArray, grd%jnx, grd%jmx)
! ---
! Scale by the scaling factor
do k=1,grd%km
- grd%chl(:,:,k) = grd%chl(:,:,k) * grd%scy(:,:,k)
+ NutArray(:,:,k) = NutArray(:,:,k) * grd%scy(:,:,k)
enddo
! ---
! Average
do k=1,grd%km
- grd%chl_ad(:,:,k) = (grd%chl_ad(:,:,k) + grd%chl(:,:,k) ) * 0.5
+ NutArrayAd(:,:,k) = (NutArrayAd(:,:,k) + NutArray(:,:,k) ) * 0.5
enddo
! 103 continue
! ---
! Vertical EOFs
- call veof_ad
+ if(drv%multiv.eq.0) &
+ call veof_nut_ad(NutArrayAd, Var)
-end subroutine ver_hor_ad
+end subroutine ver_hor_nut_ad
diff --git a/wrt_bio_stat.f90 b/wrt_chl_stat.f90
similarity index 66%
rename from wrt_bio_stat.f90
rename to wrt_chl_stat.f90
index 6679b41..7122664 100644
--- a/wrt_bio_stat.f90
+++ b/wrt_chl_stat.f90
@@ -1,7 +1,8 @@
-subroutine wrt_bio_stat
+subroutine wrt_chl_stat
use set_knd
use grd_str
+ use eof_str
use drv_str
use mpi_str
use bio_str
@@ -10,20 +11,29 @@ subroutine wrt_bio_stat
implicit none
- INTEGER(i4) :: ncid, ierr, i, j, k, l, m, mm
- INTEGER(i4) :: idP, iVar
+ INTEGER(i4) :: ncid, ierr, i, j, k, l, m, mm, my_km
+ INTEGER(i4) :: idP, iVar, idL
INTEGER(I4) :: xid,yid,depid,timeId, idTim
INTEGER :: system, SysErr
INTEGER(kind=MPI_OFFSET_KIND) :: global_im, global_jm, global_km, MyTime
INTEGER(KIND=MPI_OFFSET_KIND) :: MyCountSingle(1), MyStartSingle(1)
- CHARACTER(LEN=37) :: BioRestart
- CHARACTER(LEN=39) :: BioRestartLong
+ CHARACTER(LEN=45) :: BioRestart
+ CHARACTER(LEN=47) :: BioRestartLong
CHARACTER(LEN=6) :: MyVarName
+ CHARACTER(LEN=16) :: LimVarName
+ CHARACTER(LEN=49) :: LimCorrfile
LOGICAL, ALLOCATABLE :: MyConditions(:,:,:,:)
+ INTEGER, ALLOCATABLE :: LimitCorr(:,:,:)
+
+
+ real(r8) :: TmpVal, MyCorr, MyRatio, SMALL
+ real(r4), allocatable, dimension(:,:,:) :: ValuesToTest
+
+ ! bug fix Intel 2018
+ real(r4), allocatable, dimension(:,:,:,:) :: DumpBio
+ integer(KIND=MPI_OFFSET_KIND) :: MyStart_4d(4), MyCount_4d(4)
- real(r8) :: TmpVal, MyCorr, MyRatio
- real(r4), allocatable, dimension(:,:,:) :: DumpBio, ValuesToTest
real(r8) :: TimeArr(1)
real(r4) :: MAX_N_CHL, MAX_P_CHL, MAX_P_C, MAX_N_C
real(r4) :: OPT_N_C, OPT_P_C, OPT_S_C, LIM_THETA
@@ -35,15 +45,26 @@ subroutine wrt_bio_stat
MAX_N_C = 1.26e-2*2 ! values from BFMconsortium parametrs document (P.Lazzari)
OPT_N_C = 1.26e-2
OPT_S_C = 0.01 ! values from BFMconsortium parametrs document (P.Lazzari)
- LIM_THETA = 0.01
-
- ALLOCATE(DumpBio(grd%im,grd%jm,grd%km)); DumpBio(:,:,:) = 1.e20
- ALLOCATE(ValuesToTest(grd%im,grd%jm,grd%km)); ValuesToTest(:,:,:) = dble(0.)
- ALLOCATE(MyConditions(grd%im,grd%jm,grd%km,bio%nphy))
+ LIM_THETA = 0.001
+ SMALL = 1.e-5
+
+ MyStart_4d(1:3) = MyStart(:)
+ MyStart_4d(4) = 1
+ MyCount_4d(1:3) = MyCount(:)
+ MyCount_4d(4) = 1
+
+ my_km = grd%km
+ if(drv%multiv.eq.1) &
+ my_km = ros%kmchl
+
+ ALLOCATE(DumpBio(grd%im,grd%jm,grd%km,1)); DumpBio(:,:,:,:) = 1.e20
+ ALLOCATE(ValuesToTest(grd%im,grd%jm,my_km)); ValuesToTest(:,:,:) = dble(0.)
+ ALLOCATE(MyConditions(grd%im,grd%jm,my_km,bio%nphy))
+ ALLOCATE(LimitCorr(grd%im,grd%jm,grd%km)); LimitCorr(:,:,:) = -99
if(MyId .eq. 0) then
- write(drv%dia,*) 'writing bio structure'
- write(*,*) 'writing bio structure'
+ write(drv%dia,*) 'writing chl structure'
+ write(*,*) 'writing chl structure'
endif
global_im = GlobalRow
@@ -55,7 +76,9 @@ subroutine wrt_bio_stat
MyStartSingle(1) = 1
TimeArr(1) = DA_JulianDate
- do k=1,grd%km
+ LimitCorr(:,:,1:my_km) = 0
+
+ do k=1,my_km
do j=1,grd%jm
do i=1,grd%im
@@ -66,7 +89,11 @@ subroutine wrt_bio_stat
ValuesToTest(i,j,k) = bio%InitialChl(i,j,k) + grd%chl(i,j,k)
if(bio%ApplyConditions) then
if(ValuesToTest(i,j,k) .gt. 10*bio%InitialChl(i,j,k)) then
-
+ if(ValuesToTest(i,j,1) .gt. 0) then
+ LimitCorr(i,j,k) = 1
+ ! print*, ValuesToTest(i,j,1), bio%InitialChl(i,j,1), grd%chl(i,j,1),i,j
+ endif
+
do m=1,bio%ncmp
do l=1,bio%nphy
bio%phy(i,j,k,l,m) = 9.*bio%pquot(i,j,k,l)*bio%cquot(i,j,k,l,m)*bio%InitialChl(i,j,k)
@@ -94,13 +121,13 @@ subroutine wrt_bio_stat
do l=1,bio%nphy
iVar = l + bio%nphy*(m-1)
- if(iVar .gt. NBioVar) CYCLE
+ if(iVar .gt. NPhytoVar) CYCLE
- BioRestart = 'RESTARTS/RST.'//ShortDate//'.'//DA_VarList(iVar)//'.nc'
- BioRestartLong = 'RESTARTS/RST.'//DA_DATE//'.'//DA_VarList(iVar)//'.nc'
+ BioRestart = 'RST_after.'//ShortDate//'.'//DA_VarList(iVar)//'.nc'
+ BioRestartLong = 'RST_after.'//DA_DATE//'.'//DA_VarList(iVar)//'.nc'
if(drv%Verbose .eq. 1 .and. MyId .eq. 0) &
- print*, "Writing BioRestart ", BioRestart
+ print*, "Writing Phyto Restart ", BioRestart
ierr = nf90mpi_create(Var3DCommunicator, BioRestart, NF90_CLOBBER, MPI_INFO_NULL, ncid)
if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_create '//BioRestart, ierr)
@@ -127,7 +154,7 @@ subroutine wrt_bio_stat
ierr = nf90mpi_enddef(ncid)
if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_enddef'//DA_VarList(iVar), ierr)
- do k=1,grd%km
+ do k=1,my_km
do j=1,grd%jm
do i=1,grd%im
@@ -141,7 +168,11 @@ subroutine wrt_bio_stat
! condition applied (before apply corrections
! on the other components)
TmpVal = 0.01*bio%pquot(i,j,k,l)*bio%InitialChl(i,j,k)
- DumpBio(i,j,k) = TmpVal
+ if(TmpVal.gt.SMALL) then
+ TmpVal = SMALL
+ endif
+ DumpBio(i,j,k,1) = TmpVal
+ LimitCorr(i,j,k) = 2
! the positiveness is applied to
! the other components
@@ -166,6 +197,7 @@ subroutine wrt_bio_stat
MyCorr = bio%pquot(i,j,k,l)*bio%InitialChl(i,j,k) + bio%phy(i,j,k,l,1)
MyCorr = MyCorr/LIM_THETA - bio%pquot(i,j,k,l)*bio%cquot(i,j,k,l,m)*bio%InitialChl(i,j,k)
bio%phy(i,j,k,l,m) = max(0., MyCorr)
+ LimitCorr(i,j,k) = 3
endif
endif
@@ -178,6 +210,7 @@ subroutine wrt_bio_stat
MyCorr = bio%pquot(i,j,k,l)*bio%cquot(i,j,k,l,2)*bio%InitialChl(i,j,k) + bio%phy(i,j,k,l,2)
MyCorr = MyCorr*OPT_N_C - bio%pquot(i,j,k,l)*bio%cquot(i,j,k,l,m)*bio%InitialChl(i,j,k)
bio%phy(i,j,k,l,m) = max(0., MyCorr)
+ LimitCorr(i,j,k) = 4
endif
endif
@@ -191,6 +224,7 @@ subroutine wrt_bio_stat
MyCorr = bio%pquot(i,j,k,l)*bio%cquot(i,j,k,l,2)*bio%InitialChl(i,j,k) + bio%phy(i,j,k,l,2)
MyCorr = MyCorr*OPT_P_C - bio%pquot(i,j,k,l)*bio%cquot(i,j,k,l,m)*bio%InitialChl(i,j,k)
bio%phy(i,j,k,l,m) = max(0., MyCorr)
+ LimitCorr(i,j,k) = 5
endif
endif
@@ -204,16 +238,17 @@ subroutine wrt_bio_stat
MyCorr = bio%pquot(i,j,k,l)*bio%cquot(i,j,k,l,2)*bio%InitialChl(i,j,k) + bio%phy(i,j,k,l,2)
MyCorr = MyCorr*OPT_S_C - bio%pquot(i,j,k,l)*bio%cquot(i,j,k,l,m)*bio%InitialChl(i,j,k)
bio%phy(i,j,k,l,m) = max(0., MyCorr)
+ LimitCorr(i,j,k) = 6
endif
endif
endif ! ApplyConditions
- DumpBio(i,j,k) = bio%pquot(i,j,k,l)*bio%cquot(i,j,k,l,m)*bio%InitialChl(i,j,k) + bio%phy(i,j,k,l,m)
+ DumpBio(i,j,k,1) = bio%pquot(i,j,k,l)*bio%cquot(i,j,k,l,m)*bio%InitialChl(i,j,k) + bio%phy(i,j,k,l,m)
endif
else
- DumpBio(i,j,k) = bio%pquot(i,j,k,l)*bio%cquot(i,j,k,l,m)*bio%InitialChl(i,j,k)
+ DumpBio(i,j,k,1) = bio%pquot(i,j,k,l)*bio%cquot(i,j,k,l,m)*bio%InitialChl(i,j,k)
endif
endif
@@ -221,7 +256,15 @@ subroutine wrt_bio_stat
enddo
enddo
- ierr = nf90mpi_put_var_all(ncid,idP,DumpBio,MyStart,MyCount)
+ do k=my_km+1,grd%km
+ do j=1,grd%jm
+ do i=1,grd%im
+ DumpBio(i,j,k,1) = bio%pquot(i,j,k,l)*bio%cquot(i,j,k,l,m)*bio%InitialChl(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ ierr = nf90mpi_put_var_all(ncid,idP,DumpBio,MyStart_4d,MyCount_4d)
if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_put_var_all '//DA_VarList(iVar), ierr)
ierr = nf90mpi_put_var_all(ncid,idTim,TimeArr,MyStartSingle,MyCountSingle)
@@ -239,6 +282,52 @@ subroutine wrt_bio_stat
enddo ! l
enddo ! m
+! File for post check DA
+! plus check variables
+ LimCorrfile = 'limcorr.'//ShortDate//'.nc'
+ ierr = nf90mpi_create(Var3DCommunicator, LimCorrfile, NF90_CLOBBER, MPI_INFO_NULL, ncid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('LimCorrfile ', ierr)
+
+ ierr = nf90mpi_def_dim(ncid,'x',global_im ,xid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_dim longitude ', ierr)
+ ierr = nf90mpi_def_dim(ncid,'y' ,global_jm ,yid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_dim latitude ', ierr)
+ ierr = nf90mpi_def_dim(ncid,'z' ,global_km, depid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_dim depth ', ierr)
+
+ LimVarName='lim_to_corr_FLAG'
+
+ ierr = nf90mpi_def_var(ncid, LimVarName, nf90_int, (/xid,yid,depid/), idL )
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_var', ierr)
+
+ ! ierr = nf90mpi_def_var(ncid, 'valtest', nf90_float, (/xid,yid/), iVar1 )
+ ! if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_var', ierr)
+
+ ! ierr = nf90mpi_def_var(ncid, 'initchl', nf90_float, (/xid,yid/), iVar2 )
+ ! if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_var', ierr)
+
+ ierr = nf90mpi_enddef(ncid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_enddef', ierr)
+
+ ierr = nf90mpi_put_var_all(ncid,idL,LimitCorr,MyStart,MyCount)
+ ! ierr = nf90mpi_put_var_all(ncid,idL,LimitCorr,MyStartLim,MyCountLim)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_put_var_all ', ierr)
+
+ ! ierr =
+ ! nf90mpi_put_var_all(ncid,iVar1,ValuesToTest(:,:,1),MyStartLim,MyCountLim)
+ ! if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_put_var_all ', ierr)
+
+ ! ierr =
+ ! nf90mpi_put_var_all(ncid,iVar2,bio%InitialChl(:,:,1),MyStartLim,MyCountLim)
+ ! if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_put_var_all ', ierr)
+
+ ierr = nf90mpi_close(ncid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('LimCorrfile ', ierr)
+
+
+
+
DEALLOCATE(DumpBio, ValuesToTest, MyConditions)
-end subroutine wrt_bio_stat
\ No newline at end of file
+
+end subroutine wrt_chl_stat
diff --git a/wrt_dia.f90 b/wrt_dia.f90
index db6141a..e33276b 100644
--- a/wrt_dia.f90
+++ b/wrt_dia.f90
@@ -38,40 +38,26 @@ subroutine wrt_dia
use pnetcdf
use filenames
use mpi_str
+ use bio_str
implicit none
INTEGER(i4) :: l,i,j,k
CHARACTER :: fgrd
integer status
- integer :: ncid,xid,yid,depid,idchl
+ integer :: ncid,xid,yid,depid,idchl,idn3n,idn1p,ido2o
integer :: idvip,idmsk,eofid
- integer(kind=MPI_OFFSET_KIND) :: global_im, global_jm, global_km
+ integer(kind=MPI_OFFSET_KIND) :: global_im, global_jm, global_km, my_km
- real(r4), allocatable, dimension(:,:,:) :: Dump_chl
+ real(r4), allocatable, dimension(:,:,:) :: DumpMatrix
- ALLOCATE ( Dump_chl(grd%im,grd%jm,grd%km) ) ; Dump_chl = 0.0
+ ALLOCATE ( DumpMatrix(grd%im,grd%jm,grd%km) ) ; DumpMatrix = 0.0
! ---
! Innovations
if(MyId .eq. 0) &
write(drv%dia,*) 'writes to corrections.dat !!!!!!!!!!!!!!!!!!!!!!!!!'
- do k=1,grd%km
- do j=1,grd%jm
- do i=1,grd%im
- if (drv%argo_obs .eq. 1) then
- if (grd%msk(i,j,k) .eq. 0) then
- Dump_chl(i,j,k) = -1.
- else
- Dump_chl(i,j,k) = REAL(grd%chl(i,j,k), 4)
- endif
- else
- Dump_chl(i,j,k) = REAL(grd%chl(i,j,k), 4 )
- endif
- enddo
- enddo
- enddo
status = nf90mpi_create(Var3DCommunicator, trim(CORR_FILE), NF90_CLOBBER, &
MPI_INFO_NULL, ncid)
@@ -80,6 +66,10 @@ subroutine wrt_dia
global_im = GlobalRow
global_jm = GlobalCol
global_km = grd%km
+
+ my_km = grd%km
+ if(drv%multiv.eq.1) &
+ my_km = ros%kmchl
status = nf90mpi_def_dim(ncid,'depth' ,global_km, depid)
if (status .ne. NF90_NOERR ) call handle_err('nf90mpi_def_dim depth ', status)
@@ -88,16 +78,121 @@ subroutine wrt_dia
status = nf90mpi_def_dim(ncid,'longitude',global_im ,xid)
if (status .ne. NF90_NOERR ) call handle_err('nf90mpi_def_dim longitude ', status)
- status = nf90mpi_def_var(ncid,'chl', nf90_float, (/xid,yid,depid/), idchl )
- if (status .ne. NF90_NOERR ) call handle_err('nf90mpi_def_var', status)
+ if((drv%chl_assim .eq. 1) .or. (drv%multiv .eq. 1)) then
+ status = nf90mpi_def_var(ncid,'chl', nf90_float, (/xid,yid,depid/), idchl )
+ if (status .ne. NF90_NOERR ) call handle_err('nf90mpi_def_var chl', status)
+ status = nf90mpi_put_att(ncid,idchl , 'missing_value',1.e+20)
+ if (status .ne. NF90_NOERR ) call handle_err('nf90mpi_put_att', status)
+ endif
+ if((drv%nut .eq. 1 .and. bio%n3n .eq. 1) .or. (drv%multiv .eq. 1)) then
+ status = nf90mpi_def_var(ncid,'n3n', nf90_float, (/xid,yid,depid/), idn3n )
+ if (status .ne. NF90_NOERR ) call handle_err('nf90mpi_def_var n3n', status)
+ status = nf90mpi_put_att(ncid,idn3n , 'missing_value',1.e+20)
+ if (status .ne. NF90_NOERR ) call handle_err('nf90mpi_put_att', status)
+ endif
+ if(bio%updateN1p .eq. 1) then
+ if((drv%nut .eq. 1 .and. bio%n3n .eq. 1) .or. (drv%multiv .eq. 1)) then
+ status = nf90mpi_def_var(ncid,'n1p', nf90_float, (/xid,yid,depid/), idn1p )
+ if (status .ne. NF90_NOERR ) call handle_err('nf90mpi_def_var n1p', status)
+ status = nf90mpi_put_att(ncid,idn1p , 'missing_value',1.e+20)
+ if (status .ne. NF90_NOERR ) call handle_err('nf90mpi_put_att', status)
+ endif
+ endif
+ if(drv%nut .eq. 1 .and. bio%o2o .eq. 1) then
+ status = nf90mpi_def_var(ncid,'o2o', nf90_float, (/xid,yid,depid/), ido2o )
+ if (status .ne. NF90_NOERR ) call handle_err('nf90mpi_def_var o2o', status)
+ status = nf90mpi_put_att(ncid,ido2o , 'missing_value',1.e+20)
+ if (status .ne. NF90_NOERR ) call handle_err('nf90mpi_put_att', status)
+ endif
+
status = nf90mpi_enddef(ncid)
if (status .ne. NF90_NOERR ) call handle_err('nf90mpi_def_var', status)
-
- status = nf90mpi_put_var_all(ncid,idchl,Dump_chl,MyStart,MyCount)
- if (status .ne. NF90_NOERR ) call handle_err('nf90mpi_put_var_all', status)
+
+ if((drv%chl_assim .eq. 1) .or. (drv%multiv .eq. 1)) then
+ do k=1,my_km
+ do j=1,grd%jm
+ do i=1,grd%im
+ if(grd%msk(i,j,k) .eq. 1) then
+ DumpMatrix(i,j,k) = REAL(grd%chl(i,j,k), 4 )
+ else
+ DumpMatrix(i,j,k) = 1.e20
+ endif
+ enddo
+ enddo
+ enddo
+ do k=my_km+1,grd%km
+ do j=1,grd%jm
+ do i=1,grd%im
+ if(grd%msk(i,j,k) .eq. 1) then
+ DumpMatrix(i,j,k) = 0
+ else
+ DumpMatrix(i,j,k) = 1.e20
+ endif
+ enddo
+ enddo
+ enddo
+ status = nf90mpi_put_var_all(ncid,idchl,DumpMatrix,MyStart,MyCount)
+ if (status .ne. NF90_NOERR ) call handle_err('nf90mpi_put_var_all chl', status)
+ endif
+
+
+ if((drv%nut .eq. 1 .and. bio%n3n .eq. 1) .or. (drv%multiv .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. 1) then
+ DumpMatrix(i,j,k) = REAL(grd%n3n(i,j,k), 4 )
+ else
+ DumpMatrix(i,j,k) = 1.e20
+ endif
+ enddo
+ enddo
+ enddo
+ status = nf90mpi_put_var_all(ncid,idn3n,DumpMatrix,MyStart,MyCount)
+ if (status .ne. NF90_NOERR ) call handle_err('nf90mpi_put_var_all n3n', status)
+ endif
+
+ if (bio%updateN1p .eq. 1) then
+ if((drv%nut .eq. 1 .and. bio%n3n .eq. 1).or.(drv%multiv.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. 1) then
+ DumpMatrix(i,j,k) = REAL(grd%n3n(i,j,k)*bio%covn3n_n1p(i,j,k), 4 )
+ else
+ DumpMatrix(i,j,k) = 1.e20
+ endif
+ enddo
+ enddo
+ enddo
+ status = nf90mpi_put_var_all(ncid,idn1p,DumpMatrix,MyStart,MyCount)
+ if (status .ne. NF90_NOERR ) call handle_err('nf90mpi_put_var_all n1p', status)
+ endif
+ endif
+
+ if(drv%nut .eq. 1 .and. bio%o2o .eq. 1) then
+ do k=1,grd%km
+ do j=1,grd%jm
+ do i=1,grd%im
+ if (drv%argo_obs .eq. 1) then
+ if (grd%msk(i,j,k) .eq. 1) then
+ DumpMatrix(i,j,k) = REAL(grd%o2o(i,j,k), 4)
+ else
+ DumpMatrix(i,j,k) = 1.e20
+ endif
+ else
+ DumpMatrix(i,j,k) = REAL(grd%o2o(i,j,k), 4 )
+ endif
+ enddo
+ enddo
+ enddo
+ status = nf90mpi_put_var_all(ncid,ido2o,DumpMatrix,MyStart,MyCount)
+ if (status .ne. NF90_NOERR ) call handle_err('nf90mpi_put_var_all o2o', status)
+ endif
+
status = nf90mpi_close(ncid)
if (status .ne. NF90_NOERR ) call handle_err('nf90mpi_close', status)
- DEALLOCATE(Dump_chl)
+ DEALLOCATE(DumpMatrix)
end subroutine wrt_dia
diff --git a/wrt_nut_stat.f90 b/wrt_nut_stat.f90
new file mode 100644
index 0000000..c88af71
--- /dev/null
+++ b/wrt_nut_stat.f90
@@ -0,0 +1,211 @@
+subroutine wrt_nut_stat
+
+ use set_knd
+ use grd_str
+ use drv_str
+ use mpi_str
+ use bio_str
+ use pnetcdf
+ use da_params
+
+ implicit none
+
+ INTEGER(i4) :: ncid, ierr, i, j, k, l, m, mm
+ INTEGER(i4) :: idP, iVar
+ INTEGER(I4) :: xid,yid,depid,timeId, idTim
+ ! INTEGER(I4) :: indN3n,indN1p
+ INTEGER :: system, SysErr
+
+ INTEGER(kind=MPI_OFFSET_KIND) :: global_im, global_jm, global_km, MyTime
+ INTEGER(KIND=MPI_OFFSET_KIND) :: MyCountSingle(1), MyStartSingle(1)
+ CHARACTER(LEN=46) :: BioRestart
+ CHARACTER(LEN=47) :: BioRestartLong
+ CHARACTER(LEN=6) :: MyVarName
+
+ real(r8) :: TmpVal, MyCorr, MyRatio!, SMALL
+ real(r4), allocatable, dimension(:,:,:,:) :: ValuesToTest
+
+ ! bug fix Intel 2018
+ real(r4), allocatable, dimension(:,:,:,:) :: DumpBio
+! real(r4), allocatable, dimension(:,:,:) :: Nut
+ integer(KIND=MPI_OFFSET_KIND) :: MyStart_4d(4), MyCount_4d(4)
+
+ real(r8) :: TimeArr(1)
+
+! SMALL = 1.e-5
+
+ MyStart_4d(1:3) = MyStart(:)
+ MyStart_4d(4) = 1
+ MyCount_4d(1:3) = MyCount(:)
+ MyCount_4d(4) = 1
+
+
+ ALLOCATE(DumpBio(grd%im,grd%jm,grd%km,1)); DumpBio(:,:,:,:) = 1.e20
+ ALLOCATE(ValuesToTest(grd%im,grd%jm,grd%km,NNVar)); ValuesToTest(:,:,:,:) = dble(0.)
+! ALLOCATE(Nut(grd%im,grd%jm,grd%km)); Nut(:,:,:) = dble(0.)
+
+ if(MyId .eq. 0) then
+ write(drv%dia,*) 'writing nut structure'
+ endif
+
+
+ global_im = GlobalRow
+ global_jm = GlobalCol
+ global_km = grd%km
+ MyTime = 1
+
+ MyCountSingle(1) = 1
+ MyStartSingle(1) = 1
+ TimeArr(1) = DA_JulianDate
+
+
+ if(bio%n3n .eq. 0) then
+ write(*,*) "ERROR: Nitrate to be assimilated NOT set in namelist"
+ write(drv%dia,*) "ERROR: Nitrate to be assimilated NOT set in namelist"
+ call MPI_Barrier(Var3DCommunicator, ierr)
+ call MPI_Abort(Var3DCommunicator,-1,ierr)
+ endif
+
+ if((bio%updateN1p .eq. 1) .and. (NNVar.lt.2)) then
+ write(*,*) "ERROR: Required phosphate update but NOT set in DA_params.f90"
+ write(drv%dia,*) "ERROR: Required phosphate update but NOT set in DA_params.f90"
+ call MPI_Barrier(Var3DCommunicator, ierr)
+ call MPI_Abort(Var3DCommunicator,-1,ierr)
+ endif
+
+ ! if(MyId .eq. 0) then
+ ! write(drv%dia,*) "before 3d do"
+ ! endif
+
+ ! do l=1,NNutVar
+ ! iVar = NPhytoVar + l
+ ! if (DA_VarList(iVar) .eq. 'N3n') then
+ ! indN3n = l
+ ! endif
+ ! if(DA_VarList(iVar) .eq. 'N1p') then
+ ! indN1p = l
+ ! endif
+ ! enddo
+
+ ! The following cycle is hard coded on numbers of variables --> to be updated in a more general way
+ do k=1,grd%km
+ do j=1,grd%jm
+ do i=1,grd%im
+ if(bio%InitialNut(i,j,k,1) .lt. 1.e20) then
+ ! check obtained values and eventually
+ ! correct them in order to avoid negative concentrations
+ ! if the correction is negative, the correction must be reduced
+ ! if(bio%n3n.eq.1) then
+ ValuesToTest(i,j,k,1) = bio%InitialNut(i,j,k,1) + grd%n3n(i,j,k)
+ if(bio%updateN1p.eq.1) then
+ ValuesToTest(i,j,k,2) = bio%InitialNut(i,j,k,2) + grd%n3n(i,j,k)*bio%covn3n_n1p(i,j,k)
+ ! endif
+ ! else
+ ! ValuesToTest(i,j,k,1) = bio%InitialNut(i,j,k,1)
+ ! ValuesToTest(i,j,k,2) = bio%InitialNut(i,j,k,2)
+ ! endif
+ ! if(bio%o2o.eq.1) then
+ ! ValuesToTest(i,j,k,3) = bio%InitialNut(i,j,k,3) + grd%o2o(i,j,k)
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+
+
+
+ do l=1,NNVar
+ iVar = NPhytoVar + l
+
+ if(iVar .gt. NBioVar) then
+ if(MyId .eq. 0) &
+ write(*,*) "Warning: Reading a variable not in the DA_VarList!"
+ endif
+
+ BioRestart = 'RST_after.'//ShortDate//'.'//DA_VarList(iVar)//'.nc'
+ BioRestartLong = 'RST_after.'//DA_DATE//'.'//DA_VarList(iVar)//'.nc'
+
+ if(drv%Verbose .eq. 1 .and. MyId .eq. 0) &
+ print*, "Writing Nut Restart ", BioRestart
+
+ ierr = nf90mpi_create(Var3DCommunicator, BioRestart, NF90_CLOBBER, MPI_INFO_NULL, ncid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_create '//BioRestart, ierr)
+
+ ierr = nf90mpi_def_dim(ncid,'x',global_im ,xid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_dim longitude ', ierr)
+ ierr = nf90mpi_def_dim(ncid,'y' ,global_jm ,yid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_dim latitude ', ierr)
+ ierr = nf90mpi_def_dim(ncid,'z' ,global_km, depid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_dim depth ', ierr)
+ ierr = nf90mpi_def_dim(ncid,'time',MyTime ,timeId)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_dim time ', ierr)
+
+ MyVarName='TRN'//DA_VarList(iVar)
+
+ ierr = nf90mpi_def_var(ncid, MyVarName, nf90_float, (/xid,yid,depid,timeId/), idP )
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_var', ierr)
+
+ ierr = nf90mpi_def_var(ncid,'time' , nf90_double, (/timeid/) , idTim)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_var', ierr)
+ ierr = nf90mpi_put_att(ncid,idP , 'missing_value',1.e+20)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_put_att', ierr)
+
+ ierr = nf90mpi_enddef(ncid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_enddef'//DA_VarList(iVar), ierr)
+
+ do k=1,grd%km
+ do j=1,grd%jm
+ do i=1,grd%im
+
+ if(bio%InitialNut(i,j,k,1) .lt. 1.e20) then
+
+ if(grd%msk(i,j,k).eq.1) then
+
+ if(ValuesToTest(i,j,k,l) .lt. 0) then
+ ! Excluding negative concentrations
+ ! This correction must be the first
+ ! condition applied (before apply corrections
+ ! on the other components)
+ TmpVal = 0.1*bio%InitialNut(i,j,k,l)
+ ! if(TmpVal.gt.SMALL) then
+ ! TmpVal = SMALL
+ ! endif
+ DumpBio(i,j,k,1) = TmpVal
+
+ else
+ DumpBio(i,j,k,1) = ValuesToTest(i,j,k,l)
+ ! if(bio%ApplyConditions) then
+
+ ! endif ! ApplyConditions
+
+ endif
+ else
+ DumpBio(i,j,k,1) = bio%InitialNut(i,j,k,l)
+ endif
+
+ endif
+ enddo
+ enddo
+ enddo
+
+ ierr = nf90mpi_put_var_all(ncid,idP,DumpBio,MyStart_4d,MyCount_4d)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_put_var_all '//DA_VarList(iVar), ierr)
+
+ ierr = nf90mpi_put_var_all(ncid,idTim,TimeArr,MyStartSingle,MyCountSingle)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_put_var_all '//DA_VarList(iVar), ierr)
+
+ ierr = nf90mpi_close(ncid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_close '//BioRestart, ierr)
+
+ call MPI_Barrier(Var3DCommunicator, ierr)
+ ! only process 0 creates link to restart files
+ if(MyId .eq. 0) then
+ SysErr = system("ln -sf $PWD/"//BioRestart//" "//BioRestartLong)
+ if(SysErr /= 0) call MPI_Abort(MPI_COMM_WORLD, -1, SysErr)
+ endif
+ enddo ! l
+
+ DEALLOCATE(DumpBio, ValuesToTest)
+ ! DEALLOCATE(DumpBio, ValuesToTest, Nut)
+
+end subroutine wrt_nut_stat
diff --git a/wrt_o2o_stat.f90 b/wrt_o2o_stat.f90
new file mode 100644
index 0000000..51f70f0
--- /dev/null
+++ b/wrt_o2o_stat.f90
@@ -0,0 +1,185 @@
+subroutine wrt_o2o_stat
+
+ use set_knd
+ use grd_str
+ use drv_str
+ use mpi_str
+ use bio_str
+ use pnetcdf
+ use da_params
+
+ implicit none
+
+ INTEGER(i4) :: ncid, ierr, i, j, k, l, m, mm
+ INTEGER(i4) :: idP, iVar
+ INTEGER(i4) :: indO2o
+ INTEGER(I4) :: xid,yid,depid,timeId, idTim
+ INTEGER :: system, SysErr
+
+ INTEGER(kind=MPI_OFFSET_KIND) :: global_im, global_jm, global_km, MyTime
+ INTEGER(KIND=MPI_OFFSET_KIND) :: MyCountSingle(1), MyStartSingle(1)
+ CHARACTER(LEN=46) :: BioRestart
+ CHARACTER(LEN=47) :: BioRestartLong
+ CHARACTER(LEN=6) :: MyVarName
+
+ real(r8) :: TmpVal, MyCorr, MyRatio!, SMALL
+ real(r4), allocatable, dimension(:,:,:) :: ValuesToTest
+
+ ! bug fix Intel 2018
+ real(r4), allocatable, dimension(:,:,:,:) :: DumpBio
+! real(r4), allocatable, dimension(:,:,:) :: Nut
+ integer(KIND=MPI_OFFSET_KIND) :: MyStart_4d(4), MyCount_4d(4)
+
+ real(r8) :: TimeArr(1)
+
+! SMALL = 1.e-5
+
+ MyStart_4d(1:3) = MyStart(:)
+ MyStart_4d(4) = 1
+ MyCount_4d(1:3) = MyCount(:)
+ MyCount_4d(4) = 1
+
+
+ ALLOCATE(DumpBio(grd%im,grd%jm,grd%km,1)); DumpBio(:,:,:,:) = 1.e20
+ ALLOCATE(ValuesToTest(grd%im,grd%jm,grd%km)); ValuesToTest(:,:,:) = dble(0.)
+! ALLOCATE(Nut(grd%im,grd%jm,grd%km)); Nut(:,:,:) = dble(0.)
+
+ if(MyId .eq. 0) then
+ write(drv%dia,*) 'writing oxy structure'
+ endif
+
+
+ global_im = GlobalRow
+ global_jm = GlobalCol
+ global_km = grd%km
+ MyTime = 1
+
+ MyCountSingle(1) = 1
+ MyStartSingle(1) = 1
+ TimeArr(1) = DA_JulianDate
+
+
+ if(bio%o2o .eq. 0) then
+ write(*,*) "ERROR: Oxygen to be assimilated NOT set in namelist"
+ write(drv%dia,*) "ERROR: Oxygen to be assimilated NOT set in namelist"
+ call MPI_Barrier(Var3DCommunicator, ierr)
+ call MPI_Abort(Var3DCommunicator,-1,ierr)
+ endif
+
+ if((bio%o2o .eq. 1) .and. ((NNutVar-NNVar).lt.1)) then
+ write(*,*) "ERROR: Oxygen to be assimilated but NOT set in DA_params.f90"
+ write(drv%dia,*) "ERROR: Oxygen to be assimilated but NOT set in DA_params.f90"
+ call MPI_Barrier(Var3DCommunicator, ierr)
+ call MPI_Abort(Var3DCommunicator,-1,ierr)
+ endif
+
+
+ do k=1,grd%km
+ do j=1,grd%jm
+ do i=1,grd%im
+ if(bio%InitialNut(i,j,k,1) .lt. 1.e20) then
+ ! check obtained values and eventually
+ ! correct them in order to avoid negative concentrations
+ ! if the correction is negative, the correction must be reduced
+ ! if(bio%n3n.eq.1) then
+ ValuesToTest(i,j,k) = bio%InitialNut(i,j,k,NNVar+1) + grd%o2o(i,j,k)
+ endif
+ enddo
+ enddo
+ enddo
+
+
+
+ iVar = NPhytoVar + NNVar + 1
+
+ if(iVar .gt. NBioVar) then
+ if(MyId .eq. 0) &
+ write(*,*) "Warning: Reading a variable not in the DA_VarList!"
+ endif
+
+ BioRestart = 'RST_after.'//ShortDate//'.'//DA_VarList(iVar)//'.nc'
+ BioRestartLong = 'RST_after.'//DA_DATE//'.'//DA_VarList(iVar)//'.nc'
+
+ if(drv%Verbose .eq. 1 .and. MyId .eq. 0) &
+ print*, "Writing O2o Restart ", BioRestart
+
+ ierr = nf90mpi_create(Var3DCommunicator, BioRestart, NF90_CLOBBER, MPI_INFO_NULL, ncid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_create '//BioRestart, ierr)
+
+ ierr = nf90mpi_def_dim(ncid,'x',global_im ,xid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_dim longitude ', ierr)
+ ierr = nf90mpi_def_dim(ncid,'y' ,global_jm ,yid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_dim latitude ', ierr)
+ ierr = nf90mpi_def_dim(ncid,'z' ,global_km, depid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_dim depth ', ierr)
+ ierr = nf90mpi_def_dim(ncid,'time',MyTime ,timeId)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_dim time ', ierr)
+
+ MyVarName='TRN'//DA_VarList(iVar)
+
+ ierr = nf90mpi_def_var(ncid, MyVarName, nf90_float, (/xid,yid,depid,timeId/), idP )
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_var', ierr)
+
+ ierr = nf90mpi_def_var(ncid,'time' , nf90_double, (/timeid/) , idTim)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_var', ierr)
+ ierr = nf90mpi_put_att(ncid,idP , 'missing_value',1.e+20)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_put_att', ierr)
+
+ ierr = nf90mpi_enddef(ncid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_enddef'//DA_VarList(iVar), ierr)
+
+ do k=1,grd%km
+ do j=1,grd%jm
+ do i=1,grd%im
+
+ if(bio%InitialNut(i,j,k,NNVar+1) .lt. 1.e20) then
+
+ if(grd%msk(i,j,k).eq.1) then
+
+ if(ValuesToTest(i,j,k) .lt. 0) then
+ ! Excluding negative concentrations
+ ! This correction must be the first
+ ! condition applied (before apply corrections
+ ! on the other components)
+ TmpVal = 0.1*bio%InitialNut(i,j,k,NNVar+1)
+ ! if(TmpVal.gt.SMALL) then
+ ! TmpVal = SMALL
+ ! endif
+ DumpBio(i,j,k,1) = TmpVal
+
+ else
+ DumpBio(i,j,k,1) = ValuesToTest(i,j,k)
+ ! if(bio%ApplyConditions) then
+
+ ! endif ! ApplyConditions
+
+ endif
+ else
+ DumpBio(i,j,k,1) = bio%InitialNut(i,j,k,NNVar+1)
+ endif
+
+ endif
+ enddo
+ enddo
+ enddo
+
+ ierr = nf90mpi_put_var_all(ncid,idP,DumpBio,MyStart_4d,MyCount_4d)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_put_var_all '//DA_VarList(iVar), ierr)
+
+ ierr = nf90mpi_put_var_all(ncid,idTim,TimeArr,MyStartSingle,MyCountSingle)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_put_var_all '//DA_VarList(iVar), ierr)
+
+ ierr = nf90mpi_close(ncid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_close '//BioRestart, ierr)
+
+ call MPI_Barrier(Var3DCommunicator, ierr)
+ ! only process 0 creates link to restart files
+ if(MyId .eq. 0) then
+ SysErr = system("ln -sf $PWD/"//BioRestart//" "//BioRestartLong)
+ if(SysErr /= 0) call MPI_Abort(MPI_COMM_WORLD, -1, SysErr)
+ endif
+
+ DEALLOCATE(DumpBio, ValuesToTest)
+ ! DEALLOCATE(DumpBio, ValuesToTest, Nut)
+
+end subroutine wrt_o2o_stat
diff --git a/wrt_upd_nut.f90 b/wrt_upd_nut.f90
new file mode 100644
index 0000000..3b682a9
--- /dev/null
+++ b/wrt_upd_nut.f90
@@ -0,0 +1,185 @@
+subroutine wrt_upd_nut
+
+ use set_knd
+ use grd_str
+ use drv_str
+ use mpi_str
+ use bio_str
+ use pnetcdf
+ use da_params
+
+ implicit none
+
+ INTEGER(i4) :: ncid, ierr, i, j, k, l, m
+ INTEGER(i4) :: idP, iVar
+ INTEGER(I4) :: xid,yid,depid,timeId, idTim
+ INTEGER :: system, SysErr
+
+ INTEGER(kind=MPI_OFFSET_KIND) :: global_im, global_jm, global_km, MyTime
+ INTEGER(KIND=MPI_OFFSET_KIND) :: MyCountSingle(1), MyStartSingle(1)
+ CHARACTER(LEN=45) :: BioRestart
+ CHARACTER(LEN=47) :: BioRestartLong
+ CHARACTER(LEN=6) :: MyVarName
+
+
+ real(r8) :: TmpVal, Myn3nUpdate, Myn1pUpdate, totchl, SMALL
+ real(r4), allocatable, dimension(:,:,:,:) :: ValuesToTest
+
+ ! bug fix Intel 2018
+ real(r4), allocatable, dimension(:,:,:,:) :: DumpBio
+ integer(KIND=MPI_OFFSET_KIND) :: MyStart_4d(4), MyCount_4d(4)
+
+ real(r8) :: TimeArr(1)
+
+ SMALL = 1.e-5
+
+ MyStart_4d(1:3) = MyStart(:)
+ MyStart_4d(4) = 1
+ MyCount_4d(1:3) = MyCount(:)
+ MyCount_4d(4) = 1
+
+
+ ALLOCATE(DumpBio(grd%im,grd%jm,grd%km,1)); DumpBio(:,:,:,:) = 1.e20
+ ALLOCATE(ValuesToTest(grd%im,grd%jm,grd%km,2)); ValuesToTest(:,:,:,:) = dble(0.)
+
+ if(MyId .eq. 0) then
+ write(drv%dia,*) 'writing nut update based on chl'
+ write(*,*) 'writing nut update based on chl'
+ endif
+
+ global_im = GlobalRow
+ global_jm = GlobalCol
+ global_km = grd%km
+ MyTime = 1
+
+ MyCountSingle(1) = 1
+ MyStartSingle(1) = 1
+ TimeArr(1) = DA_JulianDate
+
+
+ do k=1,grd%km
+ do j=1,grd%jm
+ do i=1,grd%im
+ totchl = 0.
+ do l=1,bio%nphy
+ totchl = totchl + bio%phy(i,j,k,l,1)
+ enddo
+ Myn3nUpdate = totchl*bio%covn3n_chl(i,j,k)
+ ValuesToTest(i,j,k,1) = bio%InitialNut(i,j,k,1) + Myn3nUpdate
+
+ Myn1pUpdate = totchl*bio%covn1p_chl(i,j,k)
+ ValuesToTest(i,j,k,2) = bio%InitialNut(i,j,k,2) + Myn1pUpdate
+
+ enddo
+ enddo
+ enddo
+
+ ! do k=1,grd%km
+ ! do j=1,grd%jm
+ ! do i=1,grd%im
+ ! totchl = 0.
+ ! do l=1,bio%nphy
+ ! totchl = totchl + bio%phy(i,j,k,l,1)
+ ! enddo
+ ! Myn3nUpdate = totchl*bio%covn3n_chl(i,j,k)
+ ! ValuesToTest(i,j,k,1) = bio%InitialNut(i,j,k,1) + Myn3nUpdate
+
+ ! ValuesToTest(i,j,k,2) = bio%InitialNut(i,j,k,2) + Myn3nUpdate*bio%covn3n_n1p(i,j,k)
+
+ ! enddo
+ ! enddo
+ ! enddo
+
+ do l=1,2
+ iVar = NPhytoVar + l
+
+ if(iVar .gt. NBioVar) then
+ if(MyId .eq. 0) &
+ write(*,*) "Warning: Reading a variable not in the DA_VarList!"
+ endif
+
+
+ BioRestart = 'RST_after.'//ShortDate//'.'//DA_VarList(iVar)//'.nc'
+ BioRestartLong = 'RST_after.'//DA_DATE//'.'//DA_VarList(iVar)//'.nc'
+
+ if(drv%Verbose .eq. 1 .and. MyId .eq. 0) &
+ print*, "Writing Nut Restart based on chl ", BioRestart
+
+ ierr = nf90mpi_create(Var3DCommunicator, BioRestart, NF90_CLOBBER, MPI_INFO_NULL, ncid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_create '//BioRestart, ierr)
+
+ ierr = nf90mpi_def_dim(ncid,'x',global_im ,xid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_dim longitude ', ierr)
+ ierr = nf90mpi_def_dim(ncid,'y' ,global_jm ,yid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_dim latitude ', ierr)
+ ierr = nf90mpi_def_dim(ncid,'z' ,global_km, depid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_dim depth ', ierr)
+ ierr = nf90mpi_def_dim(ncid,'time',MyTime ,timeId)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_dim time ', ierr)
+
+ MyVarName='TRN'//DA_VarList(iVar)
+
+ ierr = nf90mpi_def_var(ncid, MyVarName, nf90_float, (/xid,yid,depid,timeId/), idP )
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_var', ierr)
+
+ ierr = nf90mpi_def_var(ncid,'time' , nf90_double, (/timeid/) , idTim)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_def_var', ierr)
+ ierr = nf90mpi_put_att(ncid,idP , 'missing_value',1.e+20)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_put_att', ierr)
+
+ ierr = nf90mpi_enddef(ncid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_enddef'//DA_VarList(iVar), ierr)
+
+ do k=1,grd%km
+ do j=1,grd%jm
+ do i=1,grd%im
+
+ if(bio%InitialNut(i,j,k,l) .lt. 1.e20) then
+
+ if(grd%msk(i,j,k).eq.1) then
+
+ if(ValuesToTest(i,j,k,l) .lt. 0) then
+ ! Excluding negative concentrations
+ ! This correction must be the first
+ ! condition applied (before apply corrections
+ ! on the other components)
+ TmpVal = 0.01*bio%InitialNut(i,j,k,l)
+ if(TmpVal.gt.SMALL) then
+ TmpVal = SMALL
+ endif
+ DumpBio(i,j,k,1) = TmpVal
+
+ else
+ DumpBio(i,j,k,1) = ValuesToTest(i,j,k,l)
+ endif
+ else
+ DumpBio(i,j,k,1) = bio%InitialNut(i,j,k,l)
+ endif
+
+ endif
+ enddo
+ enddo
+ enddo
+
+ ierr = nf90mpi_put_var_all(ncid,idP,DumpBio,MyStart_4d,MyCount_4d)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_put_var_all '//DA_VarList(iVar), ierr)
+
+ ierr = nf90mpi_put_var_all(ncid,idTim,TimeArr,MyStartSingle,MyCountSingle)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_put_var_all '//DA_VarList(iVar), ierr)
+
+ ierr = nf90mpi_close(ncid)
+ if (ierr .ne. NF90_NOERR ) call handle_err('nf90mpi_close '//BioRestart, ierr)
+
+ call MPI_Barrier(Var3DCommunicator, ierr)
+ ! only process 0 creates link to restart files
+ if(MyId .eq. 0) then
+ SysErr = system("ln -sf $PWD/"//BioRestart//" "//BioRestartLong)
+ if(SysErr /= 0) call MPI_Abort(MPI_COMM_WORLD, -1, SysErr)
+ endif
+ enddo ! l
+
+
+ DEALLOCATE(DumpBio, ValuesToTest)
+
+
+end subroutine wrt_upd_nut
diff --git a/x86_64.LINUX.intel.dbg.inc b/x86_64.LINUX.intel.dbg.inc
index 72281a6..cf2c1d4 100644
--- a/x86_64.LINUX.intel.dbg.inc
+++ b/x86_64.LINUX.intel.dbg.inc
@@ -17,6 +17,8 @@ LIBNCMEDLEV =./libnc-medlevel
PREPROC =
CPP += $(PREPROC)
+PETSC_LD_FLAGS := $(if $(PETSC_LIB), -L$(PETSC_LIB),)
+
# NETCDF_INC = $(NETCDFF_INC)
# NETCDF_LIB = $(NETCDFF_LIB)
@@ -24,7 +26,7 @@ CPP += $(PREPROC)
FFLAGS = -g -check bound -fpe0 -g -traceback -fp-stack-check -O0 -I$(NETCDF_INC) -I$(NETCDFF_INC) -I$(PNETCDF_INC) $(OPT_FLTCONSISTENCY) -c
CFLAGS = -I$(NETCDF_INC)
-LDFLAGS += -L$(NETCDF_LIB) -L$(NETCDFF_LIB) -L$(PETSC_LIB) -L$(PNETCDF_LIB) -lnetcdff -lnetcdf -lpetsc -lpnetcdf
+LDFLAGS += -L$(NETCDF_LIB) -L$(NETCDFF_LIB) $(PETSC_LD_FLAGS) -L$(PNETCDF_LIB) -lnetcdff -lnetcdf -lpetsc -lpnetcdf
AR = ar
# Debug options##########
diff --git a/x86_64.LINUX.intel.inc b/x86_64.LINUX.intel.inc
index b51305a..c2d33bd 100644
--- a/x86_64.LINUX.intel.inc
+++ b/x86_64.LINUX.intel.inc
@@ -17,6 +17,8 @@ LIBNCMEDLEV =./libnc-medlevel
PREPROC =
CPP += $(PREPROC)
+PETSC_LD_FLAGS := $(if $(PETSC_LIB), -L$(PETSC_LIB),)
+
# NETCDF_INC = $(NETCDFF_INC)
# NETCDF_LIB = $(NETCDFF_LIB)
@@ -24,7 +26,7 @@ CPP += $(PREPROC)
FFLAGS = -g -O2 -I$(NETCDF_INC) -I$(NETCDFF_INC) -I$(PNETCDF_INC) $(OPT_FLTCONSISTENCY) -c
CFLAGS = -O2 -I$(NETCDF_INC)
-LDFLAGS += -L$(NETCDF_LIB) -L$(NETCDFF_LIB) -L$(PETSC_LIB) -L$(PNETCDF_LIB) -lnetcdff -lnetcdf -lpetsc -lpnetcdf
+LDFLAGS += -L$(NETCDF_LIB) -L$(NETCDFF_LIB) $(PETSC_LD_FLAGS) -L$(PNETCDF_LIB) -lnetcdff -lnetcdf -lpetsc -lpnetcdf
AR = ar
# Debug options##########
diff --git a/x86_64.LINUX.mpif90.inc b/x86_64.LINUX.mpif90.inc
index 2d312ed..8dfb6a0 100644
--- a/x86_64.LINUX.mpif90.inc
+++ b/x86_64.LINUX.mpif90.inc
@@ -9,22 +9,23 @@ MPCC = mpicc
MPLD = $(MPFC)
FORTRAN_UNDERSCORE = _
-OPT_FLTCONSISTENCY =
LIBFEXIT = ./libfexit/
LIBNCMEDLEV =./libnc-medlevel
-PREPROC = -D_USE_MPI
-CPP += $(PREPROC)
+PETSC_LD_FLAGS := $(if $(PETSC_LIB), -L$(PETSC_LIB),)
# NETCDF_INC = $(NETCDFF_INC)
# NETCDF_LIB = $(NETCDFF_LIB)
-FFLAGS = -ffree-line-length-none -O2 -I$(NETCDF_INC) $(OPT_FLTCONSISTENCY) -c
-# FFLAGS = -O2 -I$(NETCDF_INC) $(OPT_FLTCONSISTENCY) -c
+PNETCDF_INC=/m100_scratch/userexternal/gbolzon0/pnetcdf/include/
+PNETCDF_LIB=/m100_scratch/userexternal/gbolzon0/pnetcdf/lib
+
+# FFLAGS = -ffree-line-length-none -O2 -I$(NETCDF_INC) $(OPT_FLTCONSISTENCY) -c
+FFLAGS = -ffree-line-length-none -O2 -I$(NETCDF_INC) -I$(NETCDFF_INC) -I$(PNETCDF_INC) -c
CFLAGS = -O2 -I$(NETCDF_INC)
-LDFLAGS += -L$(NETCDF_LIB) -lnetcdff
+LDFLAGS += -L$(NETCDF_LIB) -L$(NETCDFF_LIB) $(PETSC_LD_FLAGS) -L$(PNETCDF_LIB) -lnetcdff -lnetcdf -lpetsc -lpnetcdf
AR = ar
# Debug options##########
diff --git a/x86_64.LINUX.mpif90.netcdf.4.3.2.inc b/x86_64.LINUX.mpif90.netcdf.4.3.2.inc
index c7a42be..011f968 100644
--- a/x86_64.LINUX.mpif90.netcdf.4.3.2.inc
+++ b/x86_64.LINUX.mpif90.netcdf.4.3.2.inc
@@ -17,6 +17,8 @@ LIBNCMEDLEV =./libnc-medlevel
PREPROC = -D_USE_MPI
CPP += $(PREPROC)
+PETSC_LD_FLAGS := $(if $(PETSC_LIB), -L$(PETSC_LIB),)
+
# NETCDF_INC = $(NETCDFF_INC)
# NETCDF_LIB = $(NETCDFF_LIB)
@@ -24,7 +26,7 @@ FFLAGS = -ffree-line-length-none -O2 -I$(NETCDF_INC) -I$(NETCDFF_INC) $(OPT_FLT
# FFLAGS = -O2 -I$(NETCDF_INC) -I$(NETCDFF_INC) $(OPT_FLTCONSISTENCY) -c
CFLAGS = -O2 -I$(NETCDF_INC)
-LDFLAGS += -L$(NETCDF_LIB) -L$(NETCDFF_LIB) -L$(PETSC_LIB) -lnetcdff -lnetcdf -lpetsc
+LDFLAGS += -L$(NETCDF_LIB) -L$(NETCDFF_LIB) $(PETSC_LD_FLAGS) -lnetcdff -lnetcdf -lpetsc
AR = ar
# Debug options##########