source: NEMO/trunk/src/TOP/PISCES/SED/sedarr.F90 @ 10068

Last change on this file since 10068 was 10068, checked in by nicolasmartin, 2 years ago

First part of modifications to have a common default header : fix typos and SVN keywords properties

  • Property svn:keywords set to Id
File size: 4.1 KB
Line 
1MODULE sedarr
2   !!======================================================================
3   !!                       ***  MODULE sedarr   ***
4   !!              transform 1D (2D) array to a 2D (1D) table
5   !!======================================================================
6#if defined key_sed
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
14   IMPLICIT NONE
15   PRIVATE
16
17   INTERFACE pack_arr
18      MODULE PROCEDURE pack_arr_2d_1d , pack_arr_3d_2d 
19   END INTERFACE
20
21   INTERFACE unpack_arr
22      MODULE PROCEDURE unpack_arr_1d_2d , unpack_arr_2d_3d 
23   END INTERFACE
24
25   !! * Routine accessibility
26   PUBLIC pack_arr
27   PUBLIC unpack_arr
28
29   !!----------------------------------------------------------------------
30   !! NEMO/TOP 4.0 , NEMO Consortium (2018)
31   !! $Id$
32   !! Software governed by the CeCILL license (see ./LICENSE)
33   !!----------------------------------------------------------------------
34CONTAINS
35
36   SUBROUTINE pack_arr_2d_1d ( ndim1d, tab1d, tab2d, tab_ind )
37
38      INTEGER, INTENT(in) ::  ndim1d
39      REAL(wp), DIMENSION (jpi, jpj), INTENT(in) :: tab2d
40      INTEGER, DIMENSION (ndim1d), INTENT (in) :: tab_ind
41      REAL(wp), DIMENSION(ndim1d), INTENT (out) ::  tab1d
42
43      INTEGER ::  jn, jid, jjd
44       
45      DO jn = 1, ndim1d
46         jid        = MOD( tab_ind(jn) - 1, jpi ) + 1
47         jjd        = ( tab_ind(jn) - 1 ) / jpi + 1
48         tab1d(jn)  = tab2d(jid, jjd)
49      END DO
50
51   END SUBROUTINE pack_arr_2d_1d
52
53   SUBROUTINE unpack_arr_1d_2d ( ndim1d, tab2d, tab_ind, tab1d )
54
55      INTEGER, INTENT ( in) ::  ndim1d
56      INTEGER, DIMENSION (ndim1d) , INTENT (in) ::   tab_ind
57      REAL(wp), DIMENSION(ndim1d), INTENT (in) ::   tab1d 
58      REAL(wp), DIMENSION (jpi, jpj), INTENT ( out) ::  tab2d
59      INTEGER ::  jn, jid, jjd
60
61      DO jn = 1, ndim1d
62         jid             = MOD( tab_ind(jn) - 1, jpi) + 1
63         jjd             =    ( tab_ind(jn) - 1 ) / jpi  + 1
64         tab2d(jid, jjd) = tab1d(jn)
65      END DO
66
67   END SUBROUTINE unpack_arr_1d_2d
68
69   SUBROUTINE pack_arr_3d_2d ( ndim1d, tab2d, tab3d, tab_ind )
70
71      INTEGER, INTENT(in) :: ndim1d     
72      REAL(wp), DIMENSION(jpi,jpj,jpksed), INTENT(in) ::   tab3d     
73      INTEGER, DIMENSION(ndim1d), INTENT (in) ::   tab_ind     
74      REAL(wp), DIMENSION(ndim1d,jpksed), INTENT (out) ::    tab2d 
75      INTEGER, DIMENSION(ndim1d) ::  jid, jjd       
76      INTEGER ::    jk, jn , ji, jj
77     
78      DO jn = 1, ndim1d
79         jid(jn) = MOD( tab_ind(jn) - 1, jpi ) + 1
80         jjd(jn) = ( tab_ind(jn) - 1 ) / jpi + 1
81      END DO
82 
83      DO jk = 1, jpksed
84         DO jn = 1, ndim1d
85            ji = jid(jn)
86            jj = jjd(jn)
87            tab2d(jn,jk)  = tab3d(ji,jj,jk) 
88         ENDDO
89      ENDDO
90     
91   END SUBROUTINE pack_arr_3d_2d
92
93
94   SUBROUTINE unpack_arr_2d_3d ( ndim1d, tab3d, tab_ind, tab2d )
95
96      INTEGER, INTENT(in) :: ndim1d     
97      REAL(wp), DIMENSION(ndim1d,jpksed), INTENT(in) ::   tab2d     
98      INTEGER, DIMENSION(ndim1d), INTENT (in) ::   tab_ind     
99      REAL(wp), DIMENSION(jpi,jpj,jpksed), INTENT (out) ::    tab3d 
100      INTEGER, DIMENSION(ndim1d) ::  jid, jjd       
101      INTEGER ::   jk, jn , ji, jj
102
103     DO jn = 1, ndim1d
104         jid(jn) = MOD( tab_ind(jn) - 1, jpi ) + 1
105         jjd(jn) = ( tab_ind(jn) - 1 ) / jpi + 1
106      END DO
107 
108      DO jk = 1, jpksed
109         DO jn = 1, ndim1d
110            ji = jid(jn)
111            jj = jjd(jn)
112            tab3d(ji, jj, jk) = tab2d(jn,jk)
113         ENDDO
114      ENDDO
115
116   END SUBROUTINE unpack_arr_2d_3d
117
118#else
119   !!======================================================================
120   !! MODULE sedarr  :   Dummy module
121   !!======================================================================
122CONTAINS
123   SUBROUTINE pack_arr         ! Empty routine
124   END SUBROUTINE  pack_arr
125   SUBROUTINE unpack_arr         ! Empty routine
126   END SUBROUTINE  unpack_arr
127   !!======================================================================
128#endif
129END MODULE sedarr
Note: See TracBrowser for help on using the repository browser.