New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
sedarr.F90 in NEMO/branches/2020/dev_r13333_TOP-05_Ethe_Agrif/src/TOP/PISCES/SED – NEMO

source: NEMO/branches/2020/dev_r13333_TOP-05_Ethe_Agrif/src/TOP/PISCES/SED/sedarr.F90 @ 13373

Last change on this file since 13373 was 13373, checked in by cetlod, 4 years ago

TOP-05_Ethe_Agrif : 1st step of changes to successfully compile, see ticket #2508
  • Property svn:keywords set to Id
File size: 4.2 KB
Line 
1MODULE sedarr
2   !!======================================================================
3   !!                       ***  MODULE sedarr   ***
4   !!              transform 1D (2D) array to a 2D (1D) table
5   !!======================================================================
6
7   !!----------------------------------------------------------------------
8   !!   arr_2d_1d  : 2-D to 1-D
9   !!   arr_1d_2d  : 1-D to 2-D
10   !!----------------------------------------------------------------------
11   !! * Modules used
12   USE par_oce
13   USE par_sed
14   USE in_out_manager, ONLY : ln_timing
15   USE timing
16
17   IMPLICIT NONE
18   PRIVATE
19
20   INTERFACE pack_arr
21      MODULE PROCEDURE pack_arr_2d_1d , pack_arr_3d_2d 
22   END INTERFACE
23
24   INTERFACE unpack_arr
25      MODULE PROCEDURE unpack_arr_1d_2d , unpack_arr_2d_3d 
26   END INTERFACE
27
28   !! * Routine accessibility
29   PUBLIC pack_arr
30   PUBLIC unpack_arr
31
32   !!----------------------------------------------------------------------
33   !! NEMO/TOP 3.3 , NEMO Consortium (2010)
34   !! $Id$
35   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
36   !!----------------------------------------------------------------------
37CONTAINS
38
39   SUBROUTINE pack_arr_2d_1d ( ndim1d, tab1d, tab2d, tab_ind )
40
41      INTEGER, INTENT(in) ::  ndim1d
42      REAL(wp), DIMENSION (jpi, jpj), INTENT(in) :: tab2d
43      INTEGER, DIMENSION (ndim1d), INTENT (in) :: tab_ind
44      REAL(wp), DIMENSION(ndim1d), INTENT (out) ::  tab1d
45
46      INTEGER ::  jn, jid, jjd
47
48      IF( ln_timing )   CALL timing_start('pack_arr_2d_1d')
49       
50      DO jn = 1, ndim1d
51         jid        = MOD( tab_ind(jn) - 1, jpi ) + 1
52         jjd        = ( tab_ind(jn) - 1 ) / jpi + 1
53         tab1d(jn)  = tab2d(jid, jjd)
54      END DO
55
56      IF( ln_timing )   CALL timing_stop('pack_arr_2d_1d')
57
58   END SUBROUTINE pack_arr_2d_1d
59
60   SUBROUTINE unpack_arr_1d_2d ( ndim1d, tab2d, tab_ind, tab1d )
61
62      INTEGER, INTENT ( in) ::  ndim1d
63      INTEGER, DIMENSION (ndim1d) , INTENT (in) ::   tab_ind
64      REAL(wp), DIMENSION(ndim1d), INTENT (in) ::   tab1d 
65      REAL(wp), DIMENSION (jpi, jpj), INTENT ( out) ::  tab2d
66      INTEGER ::  jn, jid, jjd
67
68      IF( ln_timing )   CALL timing_start('unpack_arr_1d_2d')
69
70      DO jn = 1, ndim1d
71         jid             = MOD( tab_ind(jn) - 1, jpi) + 1
72         jjd             =    ( tab_ind(jn) - 1 ) / jpi  + 1
73         tab2d(jid, jjd) = tab1d(jn)
74      END DO
75
76      IF( ln_timing )   CALL timing_stop('unpack_arr_1d_2d')
77
78   END SUBROUTINE unpack_arr_1d_2d
79
80   SUBROUTINE pack_arr_3d_2d ( ndim1d, tab2d, tab3d, tab_ind )
81
82      INTEGER, INTENT(in) :: ndim1d     
83      REAL(wp), DIMENSION(jpi,jpj,jpksed), INTENT(in) ::   tab3d     
84      INTEGER, DIMENSION(ndim1d), INTENT (in) ::   tab_ind     
85      REAL(wp), DIMENSION(ndim1d,jpksed), INTENT (out) ::    tab2d 
86      INTEGER, DIMENSION(ndim1d) ::  jid, jjd       
87      INTEGER ::    jk, jn , ji, jj
88
89      IF( ln_timing )   CALL timing_start('pack_arr_2d_3d')
90     
91      DO jn = 1, ndim1d
92         jid(jn) = MOD( tab_ind(jn) - 1, jpi ) + 1
93         jjd(jn) = ( tab_ind(jn) - 1 ) / jpi + 1
94      END DO
95 
96      DO jk = 1, jpksed
97         DO jn = 1, ndim1d
98            ji = jid(jn)
99            jj = jjd(jn)
100            tab2d(jn,jk)  = tab3d(ji,jj,jk) 
101         ENDDO
102      ENDDO
103
104      IF( ln_timing )   CALL timing_stop('pack_arr_2d_3d')
105     
106   END SUBROUTINE pack_arr_3d_2d
107
108
109   SUBROUTINE unpack_arr_2d_3d ( ndim1d, tab3d, tab_ind, tab2d )
110
111      INTEGER, INTENT(in) :: ndim1d     
112      REAL(wp), DIMENSION(ndim1d,jpksed), INTENT(in) ::   tab2d     
113      INTEGER, DIMENSION(ndim1d), INTENT (in) ::   tab_ind     
114      REAL(wp), DIMENSION(jpi,jpj,jpksed), INTENT (out) ::    tab3d 
115      INTEGER, DIMENSION(ndim1d) ::  jid, jjd       
116      INTEGER ::   jk, jn , ji, jj
117      !
118      IF( ln_timing )   CALL timing_start('unpack_arr_2d_3d')
119      !
120      DO jn = 1, ndim1d
121         jid(jn) = MOD( tab_ind(jn) - 1, jpi ) + 1
122         jjd(jn) = ( tab_ind(jn) - 1 ) / jpi + 1
123      END DO
124 
125      DO jk = 1, jpksed
126         DO jn = 1, ndim1d
127            ji = jid(jn)
128            jj = jjd(jn)
129            tab3d(ji, jj, jk) = tab2d(jn,jk)
130         ENDDO
131      ENDDO
132
133      IF( ln_timing )   CALL timing_stop('unpack_arr_2d_3d')
134
135   END SUBROUTINE unpack_arr_2d_3d
136
137END MODULE sedarr
Note: See TracBrowser for help on using the repository browser.