#define TWO_WAY MODULE agrif_opa_update #if defined key_agrif USE par_oce USE oce USE dom_oce USE agrif_oce IMPLICIT NONE PRIVATE PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn INTEGER :: nbcline CONTAINS SUBROUTINE Agrif_Update_Tra( kt ) !!--------------------------------------------- !! *** ROUTINE Agrif_Update_Tra *** !!--------------------------------------------- INTEGER, INTENT(in) :: kt REAL :: ztab(jpi,jpj,jpk) IF((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN #if defined TWO_WAY Agrif_UseSpecialValueInUpdate = .TRUE. Agrif_SpecialValueFineGrid = 0. IF (MOD(nbcline,nbclineupdate) == 0) THEN CALL Agrif_Update_Variable(ztab,tn, procname=updateT) CALL Agrif_Update_Variable(ztab,sn, procname=updateS) ELSE CALL Agrif_Update_Variable(ztab,tn,locupdate=(/0,2/), procname=updateT) CALL Agrif_Update_Variable(ztab,sn,locupdate=(/0,2/), procname=updateS) ENDIF Agrif_UseSpecialValueInUpdate = .FALSE. #endif END SUBROUTINE Agrif_Update_Tra SUBROUTINE Agrif_Update_Dyn( kt ) !!--------------------------------------------- !! *** ROUTINE Agrif_Update_Dyn *** !!--------------------------------------------- INTEGER, INTENT(in) :: kt REAL(wp), DIMENSION(jpi,jpj) :: ztab2d REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztab IF ((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) Return #if defined TWO_WAY IF (mod(nbcline,nbclineupdate) == 0) THEN CALL Agrif_Update_Variable(ztab,un,procname = updateU) CALL Agrif_Update_Variable(ztab,vn,procname = updateV) ELSE CALL Agrif_Update_Variable(ztab,un,locupdate=(/0,1/),procname = updateU) CALL Agrif_Update_Variable(ztab,vn,locupdate=(/0,1/),procname = updateV) ENDIF CALL Agrif_Update_Variable(ztab2d,e1u,procname = updateU2d) CALL Agrif_Update_Variable(ztab2d,e2v,procname = updateV2d) nbcline = nbcline + 1 Agrif_UseSpecialValueInUpdate = ln_spc_dyn Agrif_SpecialValueFineGrid = 0. CALL Agrif_Update_Variable(ztab2d,sshn,procname = updateSSH) Agrif_UseSpecialValueInUpdate = .FALSE. CALL Agrif_ChildGrid_To_ParentGrid() CALL recompute_diags( kt ) CALL Agrif_ParentGrid_To_ChildGrid() #endif END SUBROUTINE Agrif_Update_Dyn SUBROUTINE recompute_diags( kt ) !!--------------------------------------------- !! *** ROUTINE recompute_diags *** !!--------------------------------------------- USE divcur USE wzvmod USE cla_div USE ocfzpt INTEGER, INTENT(in) :: kt ta = hdivb sa = rotb CALL oc_fz_pt Call div_cur(kt) hdivb = ta rotb = sa IF( n_cla == 1 ) CALL div_cla( kt ) CALL wzv( kt ) END SUBROUTINE recompute_diags SUBROUTINE updateT( tabres, i1, i2, j1, j2, k1, k2, before ) !!--------------------------------------------- !! *** ROUTINE updateT *** !!--------------------------------------------- # include "domzgr_substitute.h90" INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres LOGICAL, iNTENT(in) :: before INTEGER :: ji,jj,jk IF (before) THEN DO jk=k1,k2 DO jj=j1,j2 DO ji=i1,i2 tabres(ji,jj,jk) = tn(ji,jj,jk) END DO END DO END DO ELSE DO jk=k1,k2 DO jj=j1,j2 DO ji=i1,i2 IF( tabres(ji,jj,jk) .NE. 0. ) THEN tn(ji,jj,jk) = tabres(ji,jj,jk) * tmask(ji,jj,jk) ENDIF END DO END DO END DO ENDIF END SUBROUTINE updateT SUBROUTINE updateS( tabres, i1, i2, j1, j2, k1, k2, before ) !!--------------------------------------------- !! *** ROUTINE updateS *** !!--------------------------------------------- # include "domzgr_substitute.h90" INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres LOGICAL, iNTENT(in) :: before INTEGER :: ji,jj,jk IF (before) THEN DO jk=k1,k2 DO jj=j1,j2 DO ji=i1,i2 tabres(ji,jj,jk) = sn(ji,jj,jk) END DO END DO END DO ELSE DO jk=k1,k2 DO jj=j1,j2 DO ji=i1,i2 IF (tabres(ji,jj,jk).NE.0.) THEN sn(ji,jj,jk) = tabres(ji,jj,jk) * tmask(ji,jj,jk) ENDIF END DO END DO END DO ENDIF END SUBROUTINE updateS SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, before ) !!--------------------------------------------- !! *** ROUTINE updateu *** !!--------------------------------------------- # include "domzgr_substitute.h90" INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres LOGICAL, INTENT(in) :: before INTEGER :: ji, jj, jk REAL(wp) :: zrhoy IF (before) THEN zrhoy = Agrif_Rhoy() DO jk=k1,k2 DO jj=j1,j2 DO ji=i1,i2 tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk) #if ! defined key_zco tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3u(ji,jj,jk) #endif END DO END DO END DO tabres = zrhoy * tabres ELSE DO jk=k1,k2 DO jj=j1,j2 DO ji=i1,i2 un(ji,jj,jk) = tabres(ji,jj,jk) / (e2u(ji,jj)) un(ji,jj,jk) = un(ji,jj,jk) * umask(ji,jj,jk) #if ! defined key_zco un(ji,jj,jk) = un(ji,jj,jk) / fse3u(ji,jj,jk) #endif END DO END DO END DO ENDIF END SUBROUTINE updateu SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, before ) !!--------------------------------------------- !! *** ROUTINE updatev *** !!--------------------------------------------- # include "domzgr_substitute.h90" INTEGER :: i1,i2,j1,j2,k1,k2 INTEGER :: ji,jj,jk REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: tabres LOGICAL :: before REAL(wp) :: zrhox IF (before) THEN zrhox = Agrif_Rhox() DO jk=k1,k2 DO jj=j1,j2 DO ji=i1,i2 tabres(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk) #if ! defined key_zco tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3v(ji,jj,jk) #endif END DO END DO END DO tabres = zrhox * tabres ELSE DO jk=k1,k2 DO jj=j1,j2 DO ji=i1,i2 vn(ji,jj,jk) = tabres(ji,jj,jk) / (e1v(ji,jj)) vn(ji,jj,jk) = vn(ji,jj,jk) * vmask(ji,jj,jk) #if ! defined key_zco vn(ji,jj,jk) = vn(ji,jj,jk) / fse3v(ji,jj,jk) #endif END DO END DO END DO ENDIF END SUBROUTINE updatev SUBROUTINE updateu2d( tabres, i1, i2, j1, j2, before ) !!--------------------------------------------- !! *** ROUTINE updateu2d *** !!--------------------------------------------- # include "domzgr_substitute.h90" INTEGER, INTENT(in) :: i1, i2, j1, j2 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres LOGICAL, INTENT(in) :: before INTEGER :: ji, jj, jk REAL(wp) :: zrhoy REAL(wp) :: zhinv IF (before) THEN zrhoy = Agrif_Rhoy() DO jk = 1,jpkm1 DO jj=j1,j2 DO ji=i1,i2 tabres(ji,jj) = tabres(ji,jj) + fse3u(ji,jj,jk) * un(ji,jj,jk) END DO END DO END DO DO jj=j1,j2 DO ji=i1,i2 tabres(ji,jj) = tabres(ji,jj) * e2u(ji,jj) END DO END DO tabres = zrhoy * tabres ELSE DO jj=j1,j2 DO ji=i1,i2 IF(umask(ji,jj,1) .NE. 0.) THEN spgu(ji,jj) = 0.e0 DO jk=1,jpk spgu(ji,jj) = spgu(ji,jj) + fse3u(ji,jj,jk) * un(ji,jj,jk) END DO spgu(ji,jj) = spgu(ji,jj) * e2u(ji,jj) zhinv = (tabres(ji,jj)-spgu(ji,jj))/(hu(ji,jj)*e2u(ji,jj)) Do jk=1,jpk un(ji,jj,jk) = un(ji,jj,jk) + zhinv un(ji,jj,jk) = un(ji,jj,jk) * umask(ji,jj,jk) END DO ENDIF END DO END DO ENDIF END SUBROUTINE updateu2d SUBROUTINE updatev2d( tabres, i1, i2, j1, j2, before ) !!--------------------------------------------- !! *** ROUTINE updatev2d *** !!--------------------------------------------- INTEGER, INTENT(in) :: i1, i2, j1, j2 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres LOGICAL, INTENT(in) :: before INTEGER :: ji, jj, jk REAL(wp) :: zrhox REAL(wp) :: zhinv IF (before) THEN zrhox = Agrif_Rhox() tabres = 0.e0 DO jk = 1,jpkm1 DO jj=j1,j2 DO ji=i1,i2 tabres(ji,jj) = tabres(ji,jj) + fse3v(ji,jj,jk) * vn(ji,jj,jk) END DO END DO END DO DO jj=j1,j2 DO ji=i1,i2 tabres(ji,jj) = tabres(ji,jj) * e1v(ji,jj) END DO END DO tabres = zrhox * tabres ELSE DO jj=j1,j2 DO ji=i1,i2 IF(vmask(ji,jj,1) .NE. 0.) THEN spgv(ji,jj) = 0. DO jk=1,jpk spgv(ji,jj) = spgv(ji,jj) + fse3v(ji,jj,jk) * vn(ji,jj,jk) END DO spgv(ji,jj) = spgv(ji,jj) * e1v(ji,jj) zhinv = (tabres(ji,jj)-spgv(ji,jj))/(hv(ji,jj)*e1v(ji,jj)) DO jk=1,jpk vn(ji,jj,jk) = vn(ji,jj,jk) + zhinv vn(ji,jj,jk) = vn(ji,jj,jk) * vmask(ji,jj,jk) END DO ENDIF END DO END DO ENDIF END SUBROUTINE updatev2d SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before ) !!--------------------------------------------- !! *** ROUTINE updateSSH *** !!--------------------------------------------- # include "domzgr_substitute.h90" INTEGER, INTENT(in) :: i1, i2, j1, j2 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres LOGICAL, INTENT(in) :: before INTEGER :: ji, jj REAL(wp) :: zrhox, zrhoy IF (before) THEN zrhox = Agrif_Rhox() zrhoy = Agrif_Rhoy() DO jj=j1,j2 DO ji=i1,i2 tabres(ji,jj) = e1t(ji,jj) * e2t(ji,jj) * sshn(ji,jj) END DO END DO tabres = zrhox * zrhoy * tabres ELSE DO jj=j1,j2 DO ji=i1,i2 sshn(ji,jj) = tabres(ji,jj) / (e1t(ji,jj) * e2t(ji,jj)) sshn(ji,jj) = sshn(ji,jj) * tmask(ji,jj,1) END DO END DO ENDIF END SUBROUTINE updateSSH #else CONTAINS SUBROUTINE agrif_opa_update_empty !!--------------------------------------------- !! *** ROUTINE agrif_opa_update_empty *** !!--------------------------------------------- WRITE(*,*) 'agrif_opa_update : You should not have seen this print! error?' END SUBROUTINE agrif_opa_update_empty #endif END MODULE agrif_opa_update