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.
nemogcm_tam.F90 in branches/2012/dev_v3_4_STABLE_2012/NEMOGCM/NEMO/OPATAM_SRC – NEMO

source: branches/2012/dev_v3_4_STABLE_2012/NEMOGCM/NEMO/OPATAM_SRC/nemogcm_tam.F90 @ 4600

Last change on this file since 4600 was 4600, checked in by pabouttier, 10 years ago

Allow to initialize direct model from nemogcm_tam, see Ticket #1286
File size: 24.7 KB
Line 
1MODULE nemogcm_tam
2#if defined key_tam
3   !!======================================================================
4   !!                       ***  MODULE nemogcm   ***
5   !! Ocean system   : NEMO GCM (ocean dynamics, on-line tracers, biochemistry and sea-ice)
6   !!======================================================================
7   !! History :  OPA  ! 1990-10  (C. Levy, G. Madec)  Original code
8   !!            7.0  ! 1991-11  (M. Imbard, C. Levy, G. Madec)
9   !!            7.1  ! 1993-03  (M. Imbard, C. Levy, G. Madec, O. Marti, M. Guyon, A. Lazar,
10   !!                             P. Delecluse, C. Perigaud, G. Caniaux, B. Colot, C. Maes) release 7.1
11   !!             -   ! 1992-06  (L.Terray)  coupling implementation
12   !!             -   ! 1993-11  (M.A. Filiberti) IGLOO sea-ice
13   !!            8.0  ! 1996-03  (M. Imbard, C. Levy, G. Madec, O. Marti, M. Guyon, A. Lazar,
14   !!                             P. Delecluse, L.Terray, M.A. Filiberti, J. Vialar, A.M. Treguier, M. Levy) release 8.0
15   !!            8.1  ! 1997-06  (M. Imbard, G. Madec)
16   !!            8.2  ! 1999-11  (M. Imbard, H. Goosse)  LIM sea-ice model
17   !!                 ! 1999-12  (V. Thierry, A-M. Treguier, M. Imbard, M-A. Foujols)  OPEN-MP
18   !!                 ! 2000-07  (J-M Molines, M. Imbard)  Open Boundary Conditions  (CLIPPER)
19   !!   NEMO     1.0  ! 2002-08  (G. Madec)  F90: Free form and modules
20   !!             -   ! 2004-06  (R. Redler, NEC CCRLE, Germany) add OASIS[3/4] coupled interfaces
21   !!             -   ! 2004-08  (C. Talandier) New trends organization
22   !!             -   ! 2005-06  (C. Ethe) Add the 1D configuration possibility
23   !!             -   ! 2005-11  (V. Garnier) Surface pressure gradient organization
24   !!             -   ! 2006-03  (L. Debreu, C. Mazauric)  Agrif implementation
25   !!             -   ! 2006-04  (G. Madec, R. Benshila)  Step reorganization
26   !!             -   ! 2007-07  (J. Chanut, A. Sellar) Unstructured open boundaries (BDY)
27   !!            3.2  ! 2009-08  (S. Masson)  open/write in the listing file in mpp
28   !!            3.3  ! 2010-05  (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface
29   !!             -   ! 2010-10  (C. Ethe, G. Madec) reorganisation of initialisation phase
30   !!            3.3.1! 2011-01  (A. R. Porter, STFC Daresbury) dynamical allocation
31   !!            3.4  ! 2011-11  (C. Harris) decomposition changes for running with CICE
32   !! History of TAM:
33   !!            3.4  ! 2012-07  (P.-A. Bouttier) Phasing with 3.4 version
34   !!----------------------------------------------------------------------
35
36   !!----------------------------------------------------------------------
37   !!   nemo_gcm       : solve ocean dynamics, tracer, biogeochemistry and/or sea-ice
38   !!   nemo_init      : initialization of the NEMO system
39   !!   nemo_ctl       : initialisation of the contol print
40   !!   nemo_alloc     : dynamical allocation
41   !!   nemo_partition : calculate MPP domain decomposition
42   !!   factorise      : calculate the factors of the no. of MPI processes
43   !!----------------------------------------------------------------------
44   USE step_oce        ! module used in the ocean time stepping module
45   USE sbc_oce         ! surface boundary condition: ocean
46   USE cla             ! cross land advection               (tra_cla routine)
47   USE domcfg          ! domain configuration               (dom_cfg routine)
48   USE mppini          ! shared/distributed memory setting (mpp_init routine)
49   USE domain          ! domain initialization             (dom_init routine)
50   USE obcini          ! open boundary cond. initialization (obc_ini routine)
51   USE bdyini          ! open boundary cond. initialization (bdy_init routine)
52   USE bdydta          ! open boundary cond. initialization (bdy_dta_init routine)
53   USE bdytides        ! open boundary cond. initialization (tide_init routine)
54   USE istate          ! initial state setting          (istate_init routine)
55   USE ldfdyn          ! lateral viscosity setting      (ldfdyn_init routine)
56   USE ldftra          ! lateral diffusivity setting    (ldftra_init routine)
57   USE zdfini          ! vertical physics setting          (zdf_init routine)
58   USE phycst          ! physical constant                  (par_cst routine)
59   USE trdmod          ! momentum/tracers trends       (trd_mod_init routine)
60   USE diaptr          ! poleward transports           (dia_ptr_init routine)
61   USE diadct          ! sections transports           (dia_dct_init routine)
62   USE diaobs          ! Observation diagnostics       (dia_obs_init routine)
63   USE step            ! NEMO time-stepping                 (stp     routine)
64   USE tradmp
65   USE trabbl
66#if defined key_oasis3
67   USE cpl_oasis3      ! OASIS3 coupling
68#elif defined key_oasis4
69   USE cpl_oasis4      ! OASIS4 coupling (not working)
70#endif
71   USE c1d             ! 1D configuration
72   USE step_c1d        ! Time stepping loop for the 1D configuration
73#if defined key_top
74   USE trcini          ! passive tracer initialisation
75#endif
76   USE lib_mpp         ! distributed memory computing
77#if defined key_iomput
78   USE mod_ioclient
79#endif
80   USE nemogcm
81   USE step_tam
82   USE sbcssr_tam
83   USE step_oce_tam
84   USE zdf_oce_tam
85   USE trabbl_tam
86   USE tamtst
87   USE tamctl
88   USE lib_mpp_tam
89   USE paresp
90   !USE tamtrj
91   USE trj_tam
92   IMPLICIT NONE
93   PRIVATE
94
95   PUBLIC   nemo_gcm_tam    ! called by model.F90
96   PUBLIC   nemo_init_tam   ! needed by AGRIF
97
98   CHARACTER(lc) ::   cform_aaa="( /, 'AAAAAAAA', / ) "     ! flag for output listing
99
100   !!----------------------------------------------------------------------
101   !! NEMO/OPA 4.0 , NEMO Consortium (2011)
102   !! $Id$
103   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
104   !!----------------------------------------------------------------------
105CONTAINS
106
107   SUBROUTINE nemo_gcm_tam
108      !!----------------------------------------------------------------------
109      !!                     ***  ROUTINE nemo_gcm_tam  ***
110      !!
111      !! ** Purpose :   NEMO solves the primitive equations on an orthogonal
112      !!              curvilinear mesh on the sphere.
113      !!
114      !! ** Method  : - model general initialization
115      !!              - launch the time-stepping (stp routine)
116      !!              - finalize the run by closing files and communications
117      !!
118      !! References : Madec, Delecluse, Imbard, and Levy, 1997:  internal report, IPSL.
119      !!              Madec, 2008, internal report, IPSL.
120      !!----------------------------------------------------------------------
121      INTEGER ::   istp       ! time step index
122      !!----------------------------------------------------------------------
123      !                            !-----------------------!
124      !                            !==  Initialisations  ==!
125      CALL nemo_init               !-----------------------!
126      CALL nemo_init_tam         
127      !
128      ! check that all process are still there... If some process have an error,
129      ! they will never enter in step and other processes will wait until the end of the cpu time!
130      IF( lk_mpp )   CALL mpp_max( nstop )
131
132      IF(lwp) WRITE(numout,cform_aaa)   ! Flag AAAAAAA
133
134      !                            !-----------------------!
135      !                            !==   time stepping   ==!
136      !                            !-----------------------!
137      IF (ln_swi_opatam == 2) THEN
138         istp = nit000 - 1
139         CALL trj_rea( istp, 1)
140         istp = nit000
141         CALL istate_init_tan
142         DO istp = nit000, nitend, 1
143            CALL stp_tan( istp )
144         END DO
145         IF (lwp) THEN
146            WRITE(numout,*)
147            WRITE(numout,*) ' tamtst: Finished testing operators'
148            WRITE(numout,*) ' ------'
149            WRITE(numout,*)
150         ENDIF
151      CALL flush(numout)
152      ELSE
153         CALL tam_tst
154      ENDIF
155      !                            !------------------------!
156      !                            !==  finalize the run  ==!
157      !                            !------------------------!
158      IF(lwp) WRITE(numout,cform_aaa)   ! Flag AAAAAAA
159      !
160      IF( nstop /= 0 .AND. lwp ) THEN   ! error print
161         WRITE(numout,cform_err)
162         WRITE(numout,*) nstop, ' error have been found'
163      ENDIF
164      !
165      IF( nn_timing == 1 )   CALL timing_finalize
166      !!
167      CALL nemo_closefile
168      IF( lk_mpp )   CALL mppstop       ! end mpp communications
169      !
170   END SUBROUTINE nemo_gcm_tam
171
172
173   SUBROUTINE nemo_init_tam
174      !!----------------------------------------------------------------------
175      !!                     ***  ROUTINE nemo_init  ***
176      !!
177      !! ** Purpose :   initialization of the NEMO GCM
178      !!----------------------------------------------------------------------
179      INTEGER ::   ji            ! dummy loop indices
180      INTEGER ::   ilocal_comm   ! local integer
181      CHARACTER(len=80), DIMENSION(16) ::   cltxt
182      !!
183      NAMELIST/namctl/ ln_ctl  , nn_print, nn_ictls, nn_ictle,   &
184         &             nn_isplt, nn_jsplt, nn_jctls, nn_jctle,   &
185         &             nn_bench, nn_timing
186      !!----------------------------------------------------------------------
187      !
188      IF( ln_rnf        )   CALL sbc_rnf_init
189      !!!!!!!!!!!!! TAM initialisation !!!!!!!!!!!!!!!!!!!!!!!!!!!
190      CALL nemo_alloc_tam
191      CALL nemo_ctl_tam                          ! Control prints & Benchmark
192
193                            CALL  istate_init_tan   ! ocean initial state (Dynamics and tracers)
194                            CALL  istate_init_adj   ! ocean initial state (Dynamics and tracers)
195      !                                     ! Ocean physics
196                            CALL     sbc_init_tam   ! Forcings : surface module
197                            CALL     sbc_ssr_ini_tam   ! Forcings : surface module
198            !                                     ! Active tracers
199                            CALL tra_qsr_init_tam   ! penetrative solar radiation qsr
200      IF( lk_trabbl     )   CALL tra_bbl_init_tam   ! advective (and/or diffusive) bottom boundary layer scheme
201      IF( ln_tradmp     )   CALL tra_dmp_init_tam   ! internal damping trends
202                            CALL tra_adv_init_tam   ! horizontal & vertical advection
203                            CALL tra_ldf_init_tam   ! lateral mixing
204                            CALL tra_zdf_init_tam   ! vertical mixing and after tracer fields
205
206      !                                     ! Dynamics
207                            CALL dyn_adv_init_tam   ! advection (vector or flux form)
208                            CALL dyn_vor_init_tam   ! vorticity term including Coriolis
209                            CALL dyn_ldf_init_tam   ! lateral mixing
210                            CALL dyn_hpg_init_tam   ! horizontal gradient of Hydrostatic pressure
211                            CALL dyn_zdf_init_tam   ! vertical diffusion
212                            CALL dyn_spg_init_tam   ! surface pressure gradient
213
214      !                                     ! Misc. options
215      IF( nn_cla == 1   )   CALL cla_init_tam       ! Cross Land Advection
216                            CALL sbc_rnf_init_tam
217
218      CALL tam_tst_init
219      CALL tl_trj_ini
220   END SUBROUTINE nemo_init_tam
221
222   SUBROUTINE nemo_ctl_tam
223      !!----------------------------------------------------------------------
224      !!                     ***  ROUTINE nemo_ctl  ***
225      !!
226      !! ** Purpose :   control print setting
227      !!
228      !! ** Method  : - print namctl information and check some consistencies
229      !!----------------------------------------------------------------------
230      !
231      IF(lwp) THEN                  ! control print
232         WRITE(numout,*)
233         WRITE(numout,*) 'nemo_ctl_tam: Control prints & Benchmark'
234         WRITE(numout,*) '~~~~~~~ '
235         WRITE(numout,*) '   Namelist namctl'
236         WRITE(numout,*) '      run control (for debugging)     ln_ctl     = ', ln_ctl
237         WRITE(numout,*) '      level of print                  nn_print   = ', nn_print
238         WRITE(numout,*) '      Start i indice for SUM control  nn_ictls   = ', nn_ictls
239         WRITE(numout,*) '      End i indice for SUM control    nn_ictle   = ', nn_ictle
240         WRITE(numout,*) '      Start j indice for SUM control  nn_jctls   = ', nn_jctls
241         WRITE(numout,*) '      End j indice for SUM control    nn_jctle   = ', nn_jctle
242         WRITE(numout,*) '      number of proc. following i     nn_isplt   = ', nn_isplt
243         WRITE(numout,*) '      number of proc. following j     nn_jsplt   = ', nn_jsplt
244         WRITE(numout,*) '      benchmark parameter (0/1)       nn_bench   = ', nn_bench
245      ENDIF
246      !
247      nprint    = nn_print          ! convert DOCTOR namelist names into OLD names
248      nictls    = nn_ictls
249      nictle    = nn_ictle
250      njctls    = nn_jctls
251      njctle    = nn_jctle
252      isplt     = nn_isplt
253      jsplt     = nn_jsplt
254      nbench    = nn_bench
255      !                             ! Parameter control
256      !
257      IF( ln_ctl ) THEN                 ! sub-domain area indices for the control prints
258         IF( lk_mpp .AND. jpnij > 1 ) THEN
259            isplt = jpni   ;   jsplt = jpnj   ;   ijsplt = jpni*jpnj   ! the domain is forced to the real split domain
260         ELSE
261            IF( isplt == 1 .AND. jsplt == 1  ) THEN
262               CALL ctl_warn( ' - isplt & jsplt are equal to 1',   &
263                  &           ' - the print control will be done over the whole domain' )
264            ENDIF
265            ijsplt = isplt * jsplt            ! total number of processors ijsplt
266         ENDIF
267         IF(lwp) WRITE(numout,*)'          - The total number of processors over which the'
268         IF(lwp) WRITE(numout,*)'            print control will be done is ijsplt : ', ijsplt
269         !
270         !                              ! indices used for the SUM control
271         IF( nictls+nictle+njctls+njctle == 0 )   THEN    ! print control done over the default area
272            lsp_area = .FALSE.
273         ELSE                                             ! print control done over a specific  area
274            lsp_area = .TRUE.
275            IF( nictls < 1 .OR. nictls > jpiglo )   THEN
276               CALL ctl_warn( '          - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )
277               nictls = 1
278            ENDIF
279            IF( nictle < 1 .OR. nictle > jpiglo )   THEN
280               CALL ctl_warn( '          - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )
281               nictle = jpiglo
282            ENDIF
283            IF( njctls < 1 .OR. njctls > jpjglo )   THEN
284               CALL ctl_warn( '          - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )
285               njctls = 1
286            ENDIF
287            IF( njctle < 1 .OR. njctle > jpjglo )   THEN
288               CALL ctl_warn( '          - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )
289               njctle = jpjglo
290            ENDIF
291         ENDIF
292      ENDIF
293      !
294      IF( nbench == 1 ) THEN              ! Benchmark
295         SELECT CASE ( cp_cfg )
296         CASE ( 'gyre' )   ;   CALL ctl_warn( ' The Benchmark is activated ' )
297         CASE DEFAULT      ;   CALL ctl_stop( ' The Benchmark is based on the GYRE configuration:',   &
298            &                                 ' key_gyre must be used or set nbench = 0' )
299         END SELECT
300      ENDIF
301      !
302      IF( lk_c1d .AND. .NOT.lk_iomput )   CALL ctl_stop( 'nemo_ctl_tam: The 1D configuration must be used ',   &
303         &                                               'with the IOM Input/Output manager. '         ,   &
304         &                                               'Compile with key_iomput enabled' )
305      !
306   END SUBROUTINE nemo_ctl_tam
307
308   SUBROUTINE nemo_alloc_tam
309      !!----------------------------------------------------------------------
310      !!                     ***  ROUTINE nemo_alloc  ***
311      !!
312      !! ** Purpose :   Allocate all the dynamic arrays of the OPA modules
313      !!
314      !! ** Method  :
315      !!----------------------------------------------------------------------
316      !
317      INTEGER :: ierr
318      !!----------------------------------------------------------------------
319      !
320      ierr =        oce_alloc_tam       ( 0 )          ! ocean
321      ierr = ierr + zdf_oce_alloc_tam   (   )          ! ocean vertical physics
322      !
323      ierr = ierr + lib_mpp_alloc_adj   (numout)    ! mpp exchanges
324      ierr = ierr + trc_oce_alloc_tam   ( 0 )          ! shared TRC / TRA arrays
325      ierr = ierr + sbc_oce_alloc_tam   ( 0 )          ! shared TRC / TRA arrays
326      ierr = ierr + sol_oce_alloc_tam   ( 0 )          ! shared TRC / TRA arrays
327      !
328      IF( lk_mpp    )   CALL mpp_sum( ierr )
329      IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'nemo_alloc_tam : unable to allocate standard ocean arrays' )
330      !
331   END SUBROUTINE nemo_alloc_tam
332
333   SUBROUTINE factorise( kfax, kmaxfax, knfax, kn, kerr )
334      !!----------------------------------------------------------------------
335      !!                     ***  ROUTINE factorise  ***
336      !!
337      !! ** Purpose :   return the prime factors of n.
338      !!                knfax factors are returned in array kfax which is of
339      !!                maximum dimension kmaxfax.
340      !! ** Method  :
341      !!----------------------------------------------------------------------
342      INTEGER                    , INTENT(in   ) ::   kn, kmaxfax
343      INTEGER                    , INTENT(  out) ::   kerr, knfax
344      INTEGER, DIMENSION(kmaxfax), INTENT(  out) ::   kfax
345      !
346      INTEGER :: ifac, jl, inu
347      INTEGER, PARAMETER :: ntest = 14
348      INTEGER :: ilfax(ntest)
349
350      ! lfax contains the set of allowed factors.
351      data (ilfax(jl),jl=1,ntest) / 16384, 8192, 4096, 2048, 1024, 512, 256,  &
352         &                            128,   64,   32,   16,    8,   4,   2  /
353      !!----------------------------------------------------------------------
354
355      ! Clear the error flag and initialise output vars
356      kerr = 0
357      kfax = 1
358      knfax = 0
359
360      ! Find the factors of n.
361      IF( kn == 1 )   GOTO 20
362
363      ! nu holds the unfactorised part of the number.
364      ! knfax holds the number of factors found.
365      ! l points to the allowed factor list.
366      ! ifac holds the current factor.
367
368      inu   = kn
369      knfax = 0
370
371      DO jl = ntest, 1, -1
372         !
373         ifac = ilfax(jl)
374         IF( ifac > inu )   CYCLE
375
376         ! Test whether the factor will divide.
377
378         IF( MOD(inu,ifac) == 0 ) THEN
379            !
380            knfax = knfax + 1            ! Add the factor to the list
381            IF( knfax > kmaxfax ) THEN
382               kerr = 6
383               write (*,*) 'FACTOR: insufficient space in factor array ', knfax
384               return
385            ENDIF
386            kfax(knfax) = ifac
387            ! Store the other factor that goes with this one
388            knfax = knfax + 1
389            kfax(knfax) = inu / ifac
390            !WRITE (*,*) 'ARPDBG, factors ',knfax-1,' & ',knfax,' are ', kfax(knfax-1),' and ',kfax(knfax)
391         ENDIF
392         !
393      END DO
394
395   20 CONTINUE      ! Label 20 is the exit point from the factor search loop.
396      !
397   END SUBROUTINE factorise
398
399#if defined key_mpp_mpi
400   SUBROUTINE nemo_northcomms
401      !!======================================================================
402      !!                     ***  ROUTINE  nemo_northcomms  ***
403      !! nemo_northcomms    :  Setup for north fold exchanges with explicit peer to peer messaging
404      !!=====================================================================
405      !!----------------------------------------------------------------------
406      !!
407      !! ** Purpose :   Initialization of the northern neighbours lists.
408      !!----------------------------------------------------------------------
409      !!    1.0  ! 2011-10  (A. C. Coward, NOCS & J. Donners, PRACE)
410      !!----------------------------------------------------------------------
411
412      INTEGER ::   ji, jj, jk, ij, jtyp    ! dummy loop indices
413      INTEGER ::   ijpj                    ! number of rows involved in north-fold exchange
414      INTEGER ::   northcomms_alloc        ! allocate return status
415      REAL(wp), ALLOCATABLE, DIMENSION ( :,: ) ::   znnbrs     ! workspace
416      LOGICAL,  ALLOCATABLE, DIMENSION ( : )   ::   lrankset   ! workspace
417
418      IF(lwp) WRITE(numout,*)
419      IF(lwp) WRITE(numout,*) 'nemo_northcomms : Initialization of the northern neighbours lists'
420      IF(lwp) WRITE(numout,*) '~~~~~~~~~~'
421
422      !!----------------------------------------------------------------------
423      ALLOCATE( znnbrs(jpi,jpj), stat = northcomms_alloc )
424      ALLOCATE( lrankset(jpnij), stat = northcomms_alloc )
425      IF( northcomms_alloc /= 0 ) THEN
426         WRITE(numout,cform_war)
427         WRITE(numout,*) 'northcomms_alloc : failed to allocate arrays'
428         CALL ctl_stop( 'STOP', 'nemo_northcomms : unable to allocate temporary arrays' )
429      ENDIF
430      nsndto = 0
431      isendto = -1
432      ijpj   = 4
433      !
434      ! This routine has been called because ln_nnogather has been set true ( nammpp )
435      ! However, these first few exchanges have to use the mpi_allgather method to
436      ! establish the neighbour lists to use in subsequent peer to peer exchanges.
437      ! Consequently, set l_north_nogather to be false here and set it true only after
438      ! the lists have been established.
439      !
440      l_north_nogather = .FALSE.
441      !
442      ! Exchange and store ranks on northern rows
443
444      DO jtyp = 1,4
445
446         lrankset = .FALSE.
447         znnbrs = narea
448         SELECT CASE (jtyp)
449            CASE(1)
450               CALL lbc_lnk( znnbrs, 'T', 1. )      ! Type 1: T,W-points
451            CASE(2)
452               CALL lbc_lnk( znnbrs, 'U', 1. )      ! Type 2: U-point
453            CASE(3)
454               CALL lbc_lnk( znnbrs, 'V', 1. )      ! Type 3: V-point
455            CASE(4)
456               CALL lbc_lnk( znnbrs, 'F', 1. )      ! Type 4: F-point
457         END SELECT
458
459         IF ( njmppt(narea) .EQ. MAXVAL( njmppt ) ) THEN
460            DO jj = nlcj-ijpj+1, nlcj
461               ij = jj - nlcj + ijpj
462               DO ji = 1,jpi
463                  IF ( INT(znnbrs(ji,jj)) .NE. 0 .AND. INT(znnbrs(ji,jj)) .NE. narea ) &
464               &     lrankset(INT(znnbrs(ji,jj))) = .true.
465               END DO
466            END DO
467
468            DO jj = 1,jpnij
469               IF ( lrankset(jj) ) THEN
470                  nsndto(jtyp) = nsndto(jtyp) + 1
471                  IF ( nsndto(jtyp) .GT. jpmaxngh ) THEN
472                     CALL ctl_stop( ' Too many neighbours in nemo_northcomms ', &
473                  &                 ' jpmaxngh will need to be increased ')
474                  ENDIF
475                  isendto(nsndto(jtyp),jtyp) = jj-1   ! narea converted to MPI rank
476               ENDIF
477            END DO
478         ENDIF
479
480      END DO
481
482      !
483      ! Type 5: I-point
484      !
485      ! ICE point exchanges may involve some averaging. The neighbours list is
486      ! built up using two exchanges to ensure that the whole stencil is covered.
487      ! lrankset should not be reset between these 'J' and 'K' point exchanges
488
489      jtyp = 5
490      lrankset = .FALSE.
491      znnbrs = narea
492      CALL lbc_lnk( znnbrs, 'J', 1. ) ! first ice U-V point
493
494      IF ( njmppt(narea) .EQ. MAXVAL( njmppt ) ) THEN
495         DO jj = nlcj-ijpj+1, nlcj
496            ij = jj - nlcj + ijpj
497            DO ji = 1,jpi
498               IF ( INT(znnbrs(ji,jj)) .NE. 0 .AND. INT(znnbrs(ji,jj)) .NE. narea ) &
499            &     lrankset(INT(znnbrs(ji,jj))) = .true.
500         END DO
501        END DO
502      ENDIF
503
504      znnbrs = narea
505      CALL lbc_lnk( znnbrs, 'K', 1. ) ! second ice U-V point
506
507      IF ( njmppt(narea) .EQ. MAXVAL( njmppt )) THEN
508         DO jj = nlcj-ijpj+1, nlcj
509            ij = jj - nlcj + ijpj
510            DO ji = 1,jpi
511               IF ( INT(znnbrs(ji,jj)) .NE. 0 .AND.  INT(znnbrs(ji,jj)) .NE. narea ) &
512            &       lrankset( INT(znnbrs(ji,jj))) = .true.
513            END DO
514         END DO
515
516         DO jj = 1,jpnij
517            IF ( lrankset(jj) ) THEN
518               nsndto(jtyp) = nsndto(jtyp) + 1
519               IF ( nsndto(jtyp) .GT. jpmaxngh ) THEN
520                  CALL ctl_stop( ' Too many neighbours in nemo_northcomms ', &
521               &                 ' jpmaxngh will need to be increased ')
522               ENDIF
523               isendto(nsndto(jtyp),jtyp) = jj-1   ! narea converted to MPI rank
524            ENDIF
525         END DO
526         !
527         ! For northern row areas, set l_north_nogather so that all subsequent exchanges
528         ! can use peer to peer communications at the north fold
529         !
530         l_north_nogather = .TRUE.
531         !
532      ENDIF
533      DEALLOCATE( znnbrs )
534      DEALLOCATE( lrankset )
535
536   END SUBROUTINE nemo_northcomms
537#else
538   SUBROUTINE nemo_northcomms      ! Dummy routine
539      WRITE(*,*) 'nemo_northcomms: You should not have seen this print! error?'
540   END SUBROUTINE nemo_northcomms
541#endif
542#else
543CONTAINS
544   SUBROUTINE nemo_gcm_tam
545      WRITE(*,*) 'nemo_gcm_tam: You should not have seen this print! error?'
546   END SUBROUTINE nemo_gcm_tam
547#endif
548   !!======================================================================
549END MODULE nemogcm_tam
Note: See TracBrowser for help on using the repository browser.