Changeset 5920 for branches/NERC/dev_r5589_is_oce_cpl/NEMOGCM/NEMO/OPA_SRC/DOM/iscplhsb.F90

Timestamp:

2015-11-25T17:58:51+01:00 (8 years ago)

Author:

mathiot

Message:

ice sheet coupling: add treshold to define grounded area, remove useless va
riable, change some variable name + add some namelist parameter

File:

• branches/NERC/dev_r5589_is_oce_cpl/NEMOGCM/NEMO/OPA_SRC/DOM/iscplhsb.F90 (modified) (6 diffs)

branches/NERC/dev_r5589_is_oce_cpl/NEMOGCM/NEMO/OPA_SRC/DOM/iscplhsb.F90

@@ -33 +33 @@
    !! * Substitutions  
 #  include "domzgr_substitute.h90"  
+#  include "vectopt_loop_substitute.h90"
    !!----------------------------------------------------------------------
    !! NEMO/OPA 3.3 , NEMO Consortium (2010)
@@ -57 +58 @@
       REAL(wp),                     INTENT(in ) :: prdt_iscpl  !! coupling period 
       !!
-      INTEGER :: ji, jj, jk      !! loop index
+      INTEGER :: ji, jj, jk                                    !! loop index
       INTEGER :: jip1, jim1, jjp1, jjm1
       !!
       REAL(wp):: summsk, zsum, zsum1, zarea, zsumn, zsumb
-      REAL(wp):: r1_tiscpl
+      REAL(wp):: r1_rdtiscpl
       REAL(wp):: zjip1_ratio  , zjim1_ratio  , zjjp1_ratio  , zjjm1_ratio
       !!
-      REAL(wp), DIMENSION(:,:    ), POINTER :: zde3t, zdtem, zdsal
-      REAL(wp), DIMENSION(:,:    ), POINTER :: zssh0  
-      REAL(wp), DIMENSION(:,:,:  ), POINTER :: ztmp3d
-      !
-      REAL(wp), DIMENSION(:    ), ALLOCATABLE :: zlon, zlat
-      REAL(wp), DIMENSION(:    ), ALLOCATABLE :: zcorr_vol, zcorr_tem, zcorr_sal
-      INTEGER , DIMENSION(:    ), ALLOCATABLE :: ixpts, iypts, izpts, vnpts
+      REAL(wp):: zde3t, zdtem, zdsal
+      REAL(wp), DIMENSION(:,:), POINTER :: zdssh
+      !!
+      REAL(wp), DIMENSION(:), ALLOCATABLE :: zlon, zlat
+      REAL(wp), DIMENSION(:), ALLOCATABLE :: zcorr_vol, zcorr_tem, zcorr_sal
+      INTEGER , DIMENSION(:), ALLOCATABLE :: ixpts, iypts, izpts, vnpts
       INTEGER :: jpts, npts
 
-      CALL wrk_alloc(jpi,jpj,jpk,   ztmp3d )
-      CALL wrk_alloc(jpi,jpj,       zde3t , zdtem, zdsal )
-      CALL wrk_alloc(jpi,jpj,       zssh0  )
-
-    ! get unbalance (volume heat and salt)
-    ! initialisation
-      zde3t   (:,:)     = 0.0_wp
+      CALL wrk_alloc(jpi,jpj, zdssh )
+
+      ! get imbalance (volume heat and salt)
+      ! initialisation difference
+      zde3t = 0.0_wp; zdsal = 0.0_wp ; zdtem = 0.0_wp
+
+      ! initialisation correction term
       pvol_flx(:,:,:  ) = 0.0_wp
       pts_flx (:,:,:,:) = 0.0_wp
-      r1_tiscpl = 1._wp / (prdt_iscpl * rn_rdt) 
+      
+      r1_rdtiscpl = 1._wp / prdt_iscpl 
 
       ! mask tsn and tsb 
@@ -93 +94 @@
 
       ! 
-      zssh0(:,:)        = sshn(:,:) * ssmask(:,:) - sshb(:,:) * psmask_b(:,:)
-      IF ( lk_vvl ) zssh0 = 0.0_wp ! already include in the levels by definition
+      zdssh(:,:) = sshn(:,:) * ssmask(:,:) - sshb(:,:) * psmask_b(:,:)
+      IF ( lk_vvl ) zdssh = 0.0_wp ! already included in the levels by definition
       
       DO jk = 1,jpk-1
-         DO ji = 2,jpi-1
-            DO jj = 2,jpj-1
+         DO jj = 2,jpj-1
+            DO ji = fs_2,fs_jpim1
                IF (tmask_h(ji,jj) == 1._wp) THEN
 
                   ! volume differences
-                  zde3t(ji,jj) = fse3t_n(ji,jj,jk) * tmask(ji,jj,jk) - pe3t_b(ji,jj,jk) * ptmask_b(ji,jj,jk)
+                  zde3t = fse3t_n(ji,jj,jk) * tmask(ji,jj,jk) - pe3t_b(ji,jj,jk) * ptmask_b(ji,jj,jk)
 
                   ! heat diff
-                  zdtem(ji,jj) = tsn(ji,jj,jk,jp_tem) * fse3t_n(ji,jj,jk) *  tmask  (ji,jj,jk)   &
-                               - tsb(ji,jj,jk,jp_tem) * pe3t_b (ji,jj,jk) * ptmask_b(ji,jj,jk)
+                  zdtem = tsn(ji,jj,jk,jp_tem) * fse3t_n(ji,jj,jk) *  tmask  (ji,jj,jk)   &
+                        - tsb(ji,jj,jk,jp_tem) * pe3t_b (ji,jj,jk) * ptmask_b(ji,jj,jk)
                   ! salt diff
-                  zdsal(ji,jj) = tsn(ji,jj,jk,jp_sal) * fse3t_n(ji,jj,jk) *  tmask  (ji,jj,jk)   &
-                               - tsb(ji,jj,jk,jp_sal) * pe3t_b (ji,jj,jk) * ptmask_b(ji,jj,jk)
+                  zdsal = tsn(ji,jj,jk,jp_sal) * fse3t_n(ji,jj,jk) *  tmask  (ji,jj,jk)   &
+                        - tsb(ji,jj,jk,jp_sal) * pe3t_b (ji,jj,jk) * ptmask_b(ji,jj,jk)
                
                   ! shh changes
                   IF ( ptmask_b(ji,jj,jk) == 1._wp .OR. tmask(ji,jj,jk) == 1._wp ) THEN 
-                     zde3t(ji,jj) = zde3t(ji,jj) + zssh0(ji,jj) ! zssh0 = 0 if vvl
-                     zssh0(ji,jj) = 0._wp
+                     zde3t = zde3t + zdssh(ji,jj) ! zdssh = 0 if vvl
+                     zdssh(ji,jj) = 0._wp
                   END IF
 
                   ! volume, heat and salt differences in each cell 
-                  pvol_flx(ji,jj,jk)       =   pvol_flx(ji,jj,jk)        + zde3t(ji,jj) * r1_tiscpl
-                  pts_flx (ji,jj,jk,jp_sal)=   pts_flx (ji,jj,jk,jp_sal) + zdsal(ji,jj) * r1_tiscpl 
-                  pts_flx (ji,jj,jk,jp_tem)=   pts_flx (ji,jj,jk,jp_tem) + zdtem(ji,jj) * r1_tiscpl
+                  pvol_flx(ji,jj,jk)       =   pvol_flx(ji,jj,jk)        + zde3t * r1_rdtiscpl
+                  pts_flx (ji,jj,jk,jp_sal)=   pts_flx (ji,jj,jk,jp_sal) + zdsal * r1_rdtiscpl 
+                  pts_flx (ji,jj,jk,jp_tem)=   pts_flx (ji,jj,jk,jp_tem) + zdtem * r1_rdtiscpl
 
                   ! case where we close a cell: check if the neighbour cells are wet 
@@ -192 +193 @@
       ! fill narea location with the number of problematic point
       DO jk = 1,jpk-1
-         DO ji = 2,jpi-1
-            DO jj = 2,jpj-1
+         DO jj = 2,jpj-1
+            DO ji = fs_2,fs_jpim1
                IF (     ptmask_b(ji,jj,jk) == 1._wp .AND. tmask(ji,jj,jk+1)  == 0._wp .AND. tmask_h(ji,jj) == 1._wp  &
                   .AND. SUM(tmask(ji-1:ji+1,jj,jk)) + SUM(tmask(ji,jj-1:jj+1,jk)) == 0._wp) THEN
@@ -218 +219 @@
       jpts = SUM(vnpts(1:narea-1))
       DO jk = 1,jpk-1
-         DO ji = 2,jpi-1
-            DO jj = 2,jpj-1
+         DO jj = 2,jpj-1
+            DO ji = fs_2,fs_jpim1
                IF (     ptmask_b(ji,jj,jk) == 1._wp .AND. tmask(ji,jj,jk+1)  == 0._wp .AND. tmask_h(ji,jj) == 1._wp  &
                   .AND. SUM(tmask(ji-1:ji+1,jj,jk)) + SUM(tmask(ji,jj-1:jj+1,jk)) == 0._wp) THEN
@@ -286 +287 @@
 
       ! deallocate variables
-      CALL wrk_dealloc(jpi,jpj,jpk,   ztmp3d ) 
-      CALL wrk_dealloc(jpi,jpj,       zde3t  ) 
-      CALL wrk_dealloc(jpi,jpj,       zssh0  ) 
+      CALL wrk_dealloc(jpi,jpj, zdssh ) 
+
    END SUBROUTINE iscpl_cons