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/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/TOP/PISCES/SED – NEMO

source: NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/TOP/PISCES/SED/sedarr.F90 @ 10345

Last change on this file since 10345 was 10345, checked in by smasson, 5 years ago

dev_r10164_HPC09_ESIWACE_PREP_MERGE: merge with trunk@10344, see #2133

  • 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_sed
13   USE dom_oce
14   USE sed
15
16   IMPLICIT NONE
17   PRIVATE
18
19   INTERFACE pack_arr
20      MODULE PROCEDURE pack_arr_2d_1d , pack_arr_3d_2d 
21   END INTERFACE
22
23   INTERFACE unpack_arr
24      MODULE PROCEDURE unpack_arr_1d_2d , unpack_arr_2d_3d 
25   END INTERFACE
26
27   !! * Routine accessibility
28   PUBLIC pack_arr
29   PUBLIC unpack_arr
30
31   !!----------------------------------------------------------------------
32   !! NEMO/TOP 3.3 , NEMO Consortium (2010)
33   !! $Id$
34   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
35   !!----------------------------------------------------------------------
36CONTAINS
37
38   SUBROUTINE pack_arr_2d_1d ( ndim1d, tab1d, tab2d, tab_ind )
39
40      INTEGER, INTENT(in) ::  ndim1d
41      REAL(wp), DIMENSION (jpi, jpj), INTENT(in) :: tab2d
42      INTEGER, DIMENSION (ndim1d), INTENT (in) :: tab_ind
43      REAL(wp), DIMENSION(ndim1d), INTENT (out) ::  tab1d
44
45      INTEGER ::  jn, jid, jjd
46
47      IF( ln_timing )   CALL timing_start('pack_arr_2d_1d')
48       
49      DO jn = 1, ndim1d
50         jid        = MOD( tab_ind(jn) - 1, jpi ) + 1
51         jjd        = ( tab_ind(jn) - 1 ) / jpi + 1
52         tab1d(jn)  = tab2d(jid, jjd)
53      END DO
54
55      IF( ln_timing )   CALL timing_stop('pack_arr_2d_1d')
56
57   END SUBROUTINE pack_arr_2d_1d
58
59   SUBROUTINE unpack_arr_1d_2d ( ndim1d, tab2d, tab_ind, tab1d )
60
61      INTEGER, INTENT ( in) ::  ndim1d
62      INTEGER, DIMENSION (ndim1d) , INTENT (in) ::   tab_ind
63      REAL(wp), DIMENSION(ndim1d), INTENT (in) ::   tab1d 
64      REAL(wp), DIMENSION (jpi, jpj), INTENT ( out) ::  tab2d
65      INTEGER ::  jn, jid, jjd
66
67      IF( ln_timing )   CALL timing_start('unpack_arr_1d_2d')
68
69      DO jn = 1, ndim1d
70         jid             = MOD( tab_ind(jn) - 1, jpi) + 1
71         jjd             =    ( tab_ind(jn) - 1 ) / jpi  + 1
72         tab2d(jid, jjd) = tab1d(jn)
73      END DO
74
75      IF( ln_timing )   CALL timing_stop('unpack_arr_1d_2d')
76
77   END SUBROUTINE unpack_arr_1d_2d
78
79   SUBROUTINE pack_arr_3d_2d ( ndim1d, tab2d, tab3d, tab_ind )
80
81      INTEGER, INTENT(in) :: ndim1d     
82      REAL(wp), DIMENSION(jpi,jpj,jpksed), INTENT(in) ::   tab3d     
83      INTEGER, DIMENSION(ndim1d), INTENT (in) ::   tab_ind     
84      REAL(wp), DIMENSION(ndim1d,jpksed), INTENT (out) ::    tab2d 
85      INTEGER, DIMENSION(ndim1d) ::  jid, jjd       
86      INTEGER ::    jk, jn , ji, jj
87
88      IF( ln_timing )   CALL timing_start('pack_arr_2d_3d')
89     
90      DO jn = 1, ndim1d
91         jid(jn) = MOD( tab_ind(jn) - 1, jpi ) + 1
92         jjd(jn) = ( tab_ind(jn) - 1 ) / jpi + 1
93      END DO
94 
95      DO jk = 1, jpksed
96         DO jn = 1, ndim1d
97            ji = jid(jn)
98            jj = jjd(jn)
99            tab2d(jn,jk)  = tab3d(ji,jj,jk) 
100         ENDDO
101      ENDDO
102
103      IF( ln_timing )   CALL timing_stop('pack_arr_2d_3d')
104     
105   END SUBROUTINE pack_arr_3d_2d
106
107
108   SUBROUTINE unpack_arr_2d_3d ( ndim1d, tab3d, tab_ind, tab2d )
109
110      INTEGER, INTENT(in) :: ndim1d     
111      REAL(wp), DIMENSION(ndim1d,jpksed), INTENT(in) ::   tab2d     
112      INTEGER, DIMENSION(ndim1d), INTENT (in) ::   tab_ind     
113      REAL(wp), DIMENSION(jpi,jpj,jpksed), INTENT (out) ::    tab3d 
114      INTEGER, DIMENSION(ndim1d) ::  jid, jjd       
115      INTEGER ::   jk, jn , ji, jj
116      !
117      IF( ln_timing )   CALL timing_start('unpack_arr_2d_3d')
118      !
119      DO jn = 1, ndim1d
120         jid(jn) = MOD( tab_ind(jn) - 1, jpi ) + 1
121         jjd(jn) = ( tab_ind(jn) - 1 ) / jpi + 1
122      END DO
123 
124      DO jk = 1, jpksed
125         DO jn = 1, ndim1d
126            ji = jid(jn)
127            jj = jjd(jn)
128            tab3d(ji, jj, jk) = tab2d(jn,jk)
129         ENDDO
130      ENDDO
131
132      IF( ln_timing )   CALL timing_stop('unpack_arr_2d_3d')
133
134   END SUBROUTINE unpack_arr_2d_3d
135
136END MODULE sedarr
Note: See TracBrowser for help on using the repository browser.