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

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

Last change on this file was 15450, checked in by cetlod, 3 years ago

Some updates to make the PISCES/SED module usable. Totally orthogonal with no effect on other parts of the code
  • Property svn:keywords set to Id
File size: 4.3 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!         IF (mig(jid) == 150 .and. mjg(jjd) == 136) write(0,*) 'plante indices ',jn,ndim1d,slatit(jn),slongit(jn)
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.