source: branches/DEV_r2106_LOCEAN2010/NEMO/NST_SRC/agrif_user.F90 @ 2224

#if defined key_agrif
   !!----------------------------------------------------------------------
   !! NEMO/NST 3.3 , LOCEAN-IPSL (2010) 
   !! $Id$
   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
   !!----------------------------------------------------------------------

   SUBROUTINE Agrif_InitWorkspace
      !!----------------------------------------------------------------------
      !!                 *** ROUTINE Agrif_InitWorkspace ***
      !!----------------------------------------------------------------------
      USE par_oce
      USE dom_oce
      USE Agrif_Util
      !!
      IMPLICIT NONE
      !!
#if defined key_mpp_dyndist
      CHARACTER(len=20) :: namelistname
      INTEGER nummpp
      NAMELIST/nammpp_dyndist/ jpni, jpnj, jpnij
#endif
      !!----------------------------------------------------------------------

#if defined key_mpp_dyndist
      ! MPP dynamical distribution : read the processor cutting in the namelist
      IF( Agrif_Nbstepint() == 0 ) THEN
        nummpp = Agrif_Get_Unit()
        namelistname='namelist'
        IF(.NOT. Agrif_Root() )   namelistname=TRIM(Agrif_CFixed())//'_namelist'
        !
        OPEN (nummpp,file=namelistname,status='OLD',form='formatted')
        READ (nummpp,nammpp_dyndist)
        CLOSE(nummpp)
      ENDIF
#endif

      IF( .NOT. Agrif_Root() ) THEN
         jpiglo  = nbcellsx + 2 + 2*nbghostcells
         jpjglo  = nbcellsy + 2 + 2*nbghostcells
         jpi     = ( jpiglo-2*jpreci + (jpni-1+0) ) / jpni + 2*jpreci
         jpj     = ( jpjglo-2*jprecj + (jpnj-1+0) ) / jpnj + 2*jprecj
         jpim1   = jpi-1
         jpjm1   = jpj-1
         jpkm1   = jpk-1                                        
         jpij    = jpi*jpj
         jpidta  = jpiglo
         jpjdta  = jpjglo
         jpizoom = 1
         jpjzoom = 1
         nperio  = 0
         jperio  = 0
      ENDIF
      !
   END SUBROUTINE Agrif_InitWorkspace

#if ! defined key_offline

   SUBROUTINE Agrif_InitValues
      !!----------------------------------------------------------------------
      !!                 *** ROUTINE Agrif_InitValues ***
      !!
      !! ** Purpose :: Declaration of variables to be interpolated
      !!----------------------------------------------------------------------
      USE Agrif_Util
      USE oce 
      USE dom_oce
      USE opa
#if defined key_top
      USE trc
#endif
#if defined key_tradmp   ||   defined key_esopa
      USE tradmp
#endif
#if defined key_obc   ||   defined key_esopa
      USE obc_par
#endif
      USE sol_oce
      USE in_out_manager
      USE agrif_opa_update
      USE agrif_opa_interp
      USE agrif_opa_sponge
      USE agrif_top_update
      USE agrif_top_interp
      USE agrif_top_sponge
      !!
      IMPLICIT NONE
      !!
      REAL(wp) :: tabtemp(jpi,jpj,jpk)
#if defined key_top
      REAL(wp) :: tabtrtemp(jpi,jpj,jpk,jptra)
#endif 
      LOGICAL check_namelist
      !!----------------------------------------------------------------------

      ! 0. Initializations
      !-------------------
#if defined key_orca_r025 || defined key_orca_r05 || defined key_orca_r2 || defined key_orca_r4
      jp_cfg = -1    ! set special value for jp_cfg on fine grids
      cp_cfg = "default"
#endif

      ! Specific fine grid Initializations
#if defined key_tradmp || defined key_esopa
      ! no tracer damping on fine grids
      lk_tradmp = .FALSE.
#endif
#if defined key_obc || defined key_esopa
      ! no open boundary on fine grids
      lk_obc = .FALSE.
#endif

      Call opa_init  ! Initializations of each fine grid
      Call agrif_opa_init

      ! 1. Declaration of the type of variable which have to be interpolated
      !---------------------------------------------------------------------
      Call Agrif_Set_type(un,(/1,2,0/),(/2,3,0/))
      Call Agrif_Set_type(vn,(/2,1,0/),(/3,2,0/))

      Call Agrif_Set_type(ua,(/1,2,0/),(/2,3,0/))
      Call Agrif_Set_type(va,(/2,1,0/),(/3,2,0/))

      Call Agrif_Set_type(e1u,(/1,2/),(/2,3/))
      Call Agrif_Set_type(e2v,(/2,1/),(/3,2/))

      Call Agrif_Set_type(tn,(/2,2,0/),(/3,3,0/))
      Call Agrif_Set_type(sn,(/2,2,0/),(/3,3,0/)) 

      Call Agrif_Set_type(tb,(/2,2,0/),(/3,3,0/))
      Call Agrif_Set_type(sb,(/2,2,0/),(/3,3,0/)) 

      Call Agrif_Set_type(ta,(/2,2,0/),(/3,3,0/))
      Call Agrif_Set_type(sa,(/2,2,0/),(/3,3,0/))       

      Call Agrif_Set_type(sshn,(/2,2/),(/3,3/))
      Call Agrif_Set_type(gcb,(/2,2/),(/3,3/))

#if defined key_top
      Call Agrif_Set_type(trb,(/2,2,0,0/),(/3,3,0,0/))
      Call Agrif_Set_type(trn,(/2,2,0,0/),(/3,3,0,0/))
      Call Agrif_Set_type(tra,(/2,2,0,0/),(/3,3,0,0/))
#endif
      
      ! 2. Space directions for each variables
      !---------------------------------------
      Call Agrif_Set_raf(un,(/'x','y','N'/))
      Call Agrif_Set_raf(vn,(/'x','y','N'/))

      Call Agrif_Set_raf(ua,(/'x','y','N'/))
      Call Agrif_Set_raf(va,(/'x','y','N'/))

      Call Agrif_Set_raf(e1u,(/'x','y'/))
      Call Agrif_Set_raf(e2v,(/'x','y'/))

      Call Agrif_Set_raf(tn,(/'x','y','N'/))
      Call Agrif_Set_raf(sn,(/'x','y','N'/))

      Call Agrif_Set_raf(tb,(/'x','y','N'/))
      Call Agrif_Set_raf(sb,(/'x','y','N'/))

      Call Agrif_Set_raf(ta,(/'x','y','N'/))
      Call Agrif_Set_raf(sa,(/'x','y','N'/))      

      Call Agrif_Set_raf(sshn,(/'x','y'/))
      Call Agrif_Set_raf(gcb,(/'x','y'/))

#if defined key_top
      Call Agrif_Set_raf(trn,(/'x','y','N','N'/))
      Call Agrif_Set_raf(trb,(/'x','y','N','N'/))
      Call Agrif_Set_raf(tra,(/'x','y','N','N'/))
#endif

      ! 3. Type of interpolation
      !------------------------- 
      Call Agrif_Set_bcinterp(tn,interp=AGRIF_linear)
      Call Agrif_Set_bcinterp(sn,interp=AGRIF_linear)

      Call Agrif_Set_bcinterp(ta,interp=AGRIF_linear)
      Call Agrif_Set_bcinterp(sa,interp=AGRIF_linear)

      Call Agrif_Set_bcinterp(un,interp1=Agrif_linear,interp2=AGRIF_ppm)
      Call Agrif_Set_bcinterp(vn,interp1=AGRIF_ppm,interp2=Agrif_linear)

      Call Agrif_Set_bcinterp(ua,interp1=Agrif_linear,interp2=AGRIF_ppm)
      Call Agrif_Set_bcinterp(va,interp1=AGRIF_ppm,interp2=Agrif_linear)

      Call Agrif_Set_bcinterp(e1u,interp1=Agrif_linear,interp2=AGRIF_ppm)
      Call Agrif_Set_bcinterp(e2v,interp1=AGRIF_ppm,interp2=Agrif_linear)

#if defined key_top
      Call Agrif_Set_bcinterp(trn,interp=AGRIF_linear)
      Call Agrif_Set_bcinterp(tra,interp=AGRIF_linear)
#endif

      ! 4. Location of interpolation
      !-----------------------------
      Call Agrif_Set_bc(un,(/0,1/))
      Call Agrif_Set_bc(vn,(/0,1/))

      Call Agrif_Set_bc(e1u,(/0,0/))
      Call Agrif_Set_bc(e2v,(/0,0/))

      Call Agrif_Set_bc(tn,(/0,1/))
      Call Agrif_Set_bc(sn,(/0,1/))

      Call Agrif_Set_bc(ta,(/-3*Agrif_irhox(),0/))
      Call Agrif_Set_bc(sa,(/-3*Agrif_irhox(),0/))

      Call Agrif_Set_bc(ua,(/-2*Agrif_irhox(),0/))
      Call Agrif_Set_bc(va,(/-2*Agrif_irhox(),0/))

#if defined key_top
      Call Agrif_Set_bc(trn,(/0,1/))
      Call Agrif_Set_bc(tra,(/-3*Agrif_irhox(),0/))
#endif

      ! 5. Update type
      !--------------- 
      Call Agrif_Set_Updatetype(tn, update = AGRIF_Update_Average)
      Call Agrif_Set_Updatetype(sn, update = AGRIF_Update_Average)

      Call Agrif_Set_Updatetype(tb, update = AGRIF_Update_Average)
      Call Agrif_Set_Updatetype(sb, update = AGRIF_Update_Average)

      Call Agrif_Set_Updatetype(sshn, update = AGRIF_Update_Average)
      Call Agrif_Set_Updatetype(gcb,update = AGRIF_Update_Average)

#if defined key_top
      Call Agrif_Set_Updatetype(trn, update = AGRIF_Update_Average)
      Call Agrif_Set_Updatetype(trb, update = AGRIF_Update_Average)
#endif

      Call Agrif_Set_Updatetype(un,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average)
      Call Agrif_Set_Updatetype(vn,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy)

      Call Agrif_Set_Updatetype(e1u,update1 = Agrif_Update_Copy, update2=Agrif_Update_Average)
      Call Agrif_Set_Updatetype(e2v,update1 = Agrif_Update_Average, update2=Agrif_Update_Copy)

      ! 6. First interpolations of potentially non zero fields
      !-------------------------------------------------------
      Agrif_SpecialValue=0.
      Agrif_UseSpecialValue = .TRUE.
      Call Agrif_Bc_variable(tabtemp,tn,calledweight=1.)
      Call Agrif_Bc_variable(tabtemp,sn,calledweight=1.)
      Call Agrif_Bc_variable(tabtemp,un,calledweight=1.,procname=interpu)
      Call Agrif_Bc_variable(tabtemp,vn,calledweight=1.,procname=interpv)

      Call Agrif_Bc_variable(tabtemp,ta,calledweight=1.,procname=interptn)
      Call Agrif_Bc_variable(tabtemp,sa,calledweight=1.,procname=interpsn)

      Call Agrif_Bc_variable(tabtemp,ua,calledweight=1.,procname=interpun)
      Call Agrif_Bc_variable(tabtemp,va,calledweight=1.,procname=interpvn)

#if defined key_top
      Call Agrif_Bc_variable(tabtrtemp,trn,calledweight=1.)
      Call Agrif_Bc_variable(tabtrtemp,tra,calledweight=1.,procname=interptrn)
#endif
      Agrif_UseSpecialValue = .FALSE.

      ! 7. Some controls
      !-----------------
      check_namelist = .true.
            
      IF( check_namelist ) THEN
     
         ! Check time steps           
         IF( nint(Agrif_Rhot()) * nint(rdt) .ne. Agrif_Parent(rdt) ) THEN
            WRITE(*,*) 'incompatible time step between grids'
            WRITE(*,*) 'parent grid value : ',Agrif_Parent(rdt)
            WRITE(*,*) 'child  grid value : ',nint(rdt)
            WRITE(*,*) 'value on parent grid should be : ',rdt*Agrif_Rhot()
            STOP
         ENDIF
         
         ! Check run length
         IF( Agrif_IRhot() * (Agrif_Parent(nitend)- &
            Agrif_Parent(nit000)+1) .ne. (nitend-nit000+1) ) THEN
            WRITE(*,*) 'incompatible run length between grids'
            WRITE(*,*) 'parent grid value : ',(Agrif_Parent(nitend)- &
               Agrif_Parent(nit000)+1),' time step'
            WRITE(*,*) 'child  grid value : ', &
               (nitend-nit000+1),' time step'
            WRITE(*,*) 'value on child grid should be : ', &
               Agrif_IRhot() * (Agrif_Parent(nitend)- &
               Agrif_Parent(nit000)+1)
            STOP
         ENDIF
         
         ! Check coordinates
         IF( ln_zps ) THEN
            ! check parameters for partial steps 
            IF( Agrif_Parent(e3zps_min) .ne. e3zps_min ) THEN
               WRITE(*,*) 'incompatible e3zps_min between grids'
               WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_min)
               WRITE(*,*) 'child grid  :',e3zps_min
               WRITE(*,*) 'those values should be identical'
               STOP
            ENDIF          
            IF( Agrif_Parent(e3zps_rat) .ne. e3zps_rat ) THEN
               WRITE(*,*) 'incompatible e3zps_rat between grids'
               WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_rat)
               WRITE(*,*) 'child grid  :',e3zps_rat
               WRITE(*,*) 'those values should be identical'                  
               STOP
            ENDIF
         ENDIF
#if defined key_top
        ! Check passive tracer cell
        IF( nn_dttrc .ne. 1 ) THEN
           WRITE(*,*) 'nn_dttrc should be equal to 1'
        ENDIF
#endif

      ENDIF

#if defined key_top
      CALL Agrif_Update_trc(0)
#endif
      CALL Agrif_Update_tra(0)
      CALL Agrif_Update_dyn(0)

#if defined key_top
      nbcline_trc = 0
#endif
      nbcline = 0
      !
   END SUBROUTINE Agrif_InitValues

#else

   SUBROUTINE Agrif_InitValues
      !!----------------------------------------------------------------------
      !!                 *** ROUTINE Agrif_InitValues ***
      !!
      !! ** Purpose :: Declaration of variables to be interpolated
      !!----------------------------------------------------------------------
      USE Agrif_Util
      USE oce 
      USE dom_oce
      USE opa
      USE trc
      USE in_out_manager
      USE agrif_top_update
      USE agrif_top_interp
      USE agrif_top_sponge
      !!
      IMPLICIT NONE
      !!
      REAL(wp) :: tabtrtemp(jpi,jpj,jpk,jptra)
      LOGICAL check_namelist
      !!----------------------------------------------------------------------

      ! 0. Initializations
      !-------------------
#if defined key_orca_r025 || defined key_orca_r05 || defined key_orca_r2 || defined key_orca_r4
      jp_cfg = -1    ! set special value for jp_cfg on fine grids
      cp_cfg = "default"
#endif

      Call opa_init  ! Initializations of each fine grid
      Call agrif_opa_init

      ! 1. Declaration of the type of variable which have to be interpolated
      !---------------------------------------------------------------------
      Call Agrif_Set_type(trb,(/2,2,0,0/),(/3,3,0,0/))
      Call Agrif_Set_type(trn,(/2,2,0,0/),(/3,3,0,0/))
      Call Agrif_Set_type(tra,(/2,2,0,0/),(/3,3,0,0/))
      
      ! 2. Space directions for each variables
      !---------------------------------------
      Call Agrif_Set_raf(trn,(/'x','y','N','N'/))
      Call Agrif_Set_raf(trb,(/'x','y','N','N'/))
      Call Agrif_Set_raf(tra,(/'x','y','N','N'/))

      ! 3. Type of interpolation
      !------------------------- 
      Call Agrif_Set_bcinterp(trn,interp=AGRIF_linear)
      Call Agrif_Set_bcinterp(tra,interp=AGRIF_linear)

      ! 4. Location of interpolation
      !-----------------------------
      Call Agrif_Set_bc(trn,(/0,1/))
      Call Agrif_Set_bc(tra,(/-3*Agrif_irhox(),0/))

      ! 5. Update type
      !--------------- 
      Call Agrif_Set_Updatetype(trn, update = AGRIF_Update_Average)
      Call Agrif_Set_Updatetype(trb, update = AGRIF_Update_Average)

      ! 6. First interpolations of potentially non zero fields
      !-------------------------------------------------------
      Agrif_SpecialValue=0.
      Agrif_UseSpecialValue = .TRUE.
      Call Agrif_Bc_variable(tabtrtemp,trn,calledweight=1.)
      Call Agrif_Bc_variable(tabtrtemp,tra,calledweight=1.,procname=interptrn)
      Agrif_UseSpecialValue = .FALSE.

      ! 7. Some controls
      !-----------------
      check_namelist = .true.
            
      IF( check_namelist ) THEN
     
         ! Check time steps           
         IF( nint(Agrif_Rhot()) * nint(rdt) .ne. Agrif_Parent(rdt) ) THEN
            WRITE(*,*) 'incompatible time step between grids'
            WRITE(*,*) 'parent grid value : ',Agrif_Parent(rdt)
            WRITE(*,*) 'child  grid value : ',nint(rdt)
            WRITE(*,*) 'value on parent grid should be : ',rdt*Agrif_Rhot()
            STOP
         ENDIF
         
         ! Check run length
         IF( Agrif_IRhot() * (Agrif_Parent(nitend)- &
            Agrif_Parent(nit000)+1) .ne. (nitend-nit000+1) ) THEN
            WRITE(*,*) 'incompatible run length between grids'
            WRITE(*,*) 'parent grid value : ',(Agrif_Parent(nitend)- &
               Agrif_Parent(nit000)+1),' time step'
            WRITE(*,*) 'child  grid value : ', &
               (nitend-nit000+1),' time step'
            WRITE(*,*) 'value on child grid should be : ', &
               Agrif_IRhot() * (Agrif_Parent(nitend)- &
               Agrif_Parent(nit000)+1)
            STOP
         ENDIF
         
         ! Check coordinates
         IF( ln_zps ) THEN
            ! check parameters for partial steps 
            IF( Agrif_Parent(e3zps_min) .ne. e3zps_min ) THEN
               WRITE(*,*) 'incompatible e3zps_min between grids'
               WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_min)
               WRITE(*,*) 'child grid  :',e3zps_min
               WRITE(*,*) 'those values should be identical'
               STOP
            ENDIF          
            IF( Agrif_Parent(e3zps_rat) .ne. e3zps_rat ) THEN
               WRITE(*,*) 'incompatible e3zps_rat between grids'
               WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_rat)
               WRITE(*,*) 'child grid  :',e3zps_rat
               WRITE(*,*) 'those values should be identical'                  
               STOP
            ENDIF
         ENDIF
        ! Check passive tracer cell
        IF( nn_dttrc .ne. 1 ) THEN
           WRITE(*,*) 'nn_dttrc should be equal to 1'
        ENDIF

      ENDIF

      CALL Agrif_Update_trc(0)
      nbcline_trc = 0
      !
   END SUBROUTINE Agrif_InitValues

#endif
   
   SUBROUTINE Agrif_detect( g, sizex )
      !!----------------------------------------------------------------------
      !!   *** ROUTINE Agrif_detect ***
      !!----------------------------------------------------------------------
      USE Agrif_Types
      !! 
      INTEGER, DIMENSION(2) :: sizex
      INTEGER, DIMENSION(sizex(1),sizex(2)) :: g 
      !!----------------------------------------------------------------------
      !
      RETURN
      !
   END SUBROUTINE Agrif_detect


   SUBROUTINE agrif_opa_init
      !!----------------------------------------------------------------------
      !!                     *** ROUTINE agrif_init ***
      !!----------------------------------------------------------------------
      USE agrif_oce 
      USE in_out_manager
      !!
      IMPLICIT NONE
      !!
      NAMELIST/namagrif/ nn_cln_update, rn_sponge_tra, rn_sponge_dyn, ln_spc_dyn
      !!----------------------------------------------------------------------

      REWIND( numnam )                ! Read namagrif namelist
      READ  ( numnam, namagrif )
      !
      IF(lwp) THEN                    ! control print
         WRITE(numout,*)
         WRITE(numout,*) 'agrif_opa_init : AGRIF parameters'
         WRITE(numout,*) '~~~~~~~~~~~~'
         WRITE(numout,*) '   Namelist namagrif : set AGRIF parameters'
         WRITE(numout,*) '      baroclinic update frequency       nn_cln_update = ', nn_cln_update
         WRITE(numout,*) '      sponge coefficient for tracers    rn_sponge_tra = ', rn_sponge_tra, ' s'
         WRITE(numout,*) '      sponge coefficient for dynamics   rn_sponge_tra = ', rn_sponge_dyn, ' s'
         WRITE(numout,*) '      use special values for dynamics   ln_spc_dyn    = ', ln_spc_dyn
         WRITE(numout,*) 
      ENDIF
      !
      ! convert DOCTOR namelist name into OLD names
      nbclineupdate = nn_cln_update
      visc_tra      = rn_sponge_tra
      visc_dyn      = rn_sponge_dyn
      !
    END SUBROUTINE agrif_opa_init

# if defined key_mpp_mpi

   SUBROUTINE Agrif_InvLoc( indloc, nprocloc, i, indglob )
      !!----------------------------------------------------------------------
      !!                     *** ROUTINE Agrif_detect ***
      !!----------------------------------------------------------------------
      USE dom_oce
      !!
      IMPLICIT NONE
      !!
      INTEGER :: indglob,indloc,nprocloc,i
      !!----------------------------------------------------------------------
      !
      SELECT CASE(i)
      CASE(1)
         indglob = indloc + nimppt(nprocloc+1) - 1
      CASE(2)
         indglob = indloc + njmppt(nprocloc+1) - 1 
      CASE(3)
         indglob = indloc
      CASE(4)
         indglob = indloc
      END SELECT
      !
   END SUBROUTINE Agrif_InvLoc

# endif

#else
   SUBROUTINE Subcalledbyagrif
      !!----------------------------------------------------------------------
      !!   *** ROUTINE Subcalledbyagrif ***
      !!----------------------------------------------------------------------
      WRITE(*,*) 'Impossible to be here'
   END SUBROUTINE Subcalledbyagrif
#endif