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.F90 in branches/2012/dev_r3379_CMCC6_topbfm/NEMOGCM/NEMO/OFF_SRC – NEMO

source: branches/2012/dev_r3379_CMCC6_topbfm/NEMOGCM/NEMO/OFF_SRC/nemogcm.F90 @ 3561

Last change on this file since 3561 was 3561, checked in by vichi, 10 years ago

Corrected bug in directory of ocean input files

It was not possible to read ocean input files from an external directory.
Also updated the header of ocean.output with the list of institutes

File size: 28.0 KB
Line 
1MODULE nemogcm
2   !!======================================================================
3   !!                       ***  MODULE nemogcm   ***
4   !! Off-line Ocean   : passive tracer evolution, dynamics read in files
5   !!======================================================================
6   !! History :  3.3  ! 2010-05  (C. Ethe)  Full reorganization of the off-line: phasing with the on-line
7   !!            4.0  ! 2011-01  (C. Ethe, A. R. Porter, STFC Daresbury) dynamical allocation
8   !!----------------------------------------------------------------------
9
10   !!----------------------------------------------------------------------
11   !!   nemo_gcm        : off-line: solve ocean tracer only
12   !!   nemo_init       : initialization of the nemo model
13   !!   nemo_ctl        : initialisation of algorithm flag
14   !!   nemo_closefile  : close remaining files
15   !!----------------------------------------------------------------------
16   USE dom_oce         ! ocean space domain variables
17   USE oce             ! dynamics and tracers variables
18   USE c1d             ! 1D configuration
19   USE domcfg          ! domain configuration               (dom_cfg routine)
20   USE domain          ! domain initialization             (dom_init routine)
21   USE istate          ! initial state setting          (istate_init routine)
22   USE eosbn2          ! equation of state            (eos bn2 routine)
23   !              ! ocean physics
24   USE ldftra          ! lateral diffusivity setting    (ldf_tra_init routine)
25   USE ldfslp          ! slopes of neutral surfaces     (ldf_slp_init routine)
26   USE traqsr          ! solar radiation penetration    (tra_qsr_init routine)
27   USE trabbl          ! bottom boundary layer          (tra_bbl_init routine)
28   USE zdfini          ! vertical physics: initialization
29   USE sbcmod          ! surface boundary condition       (sbc_init     routine)
30   USE phycst          ! physical constant                  (par_cst routine)
31   USE dtadyn          ! Lecture and Interpolation of the dynamical fields
32   USE trcini          ! Initilization of the passive tracers
33   USE daymod          ! calendar                         (day     routine)
34   USE trcstp          ! passive tracer time-stepping      (trc_stp routine)
35   USE dtadyn          ! Lecture and interpolation of the dynamical fields
36   USE stpctl          ! time stepping control            (stp_ctl routine)
37   !              ! I/O & MPP
38   USE iom             ! I/O library
39   USE in_out_manager  ! I/O manager
40   USE mppini          ! shared/distributed memory setting (mpp_init routine)
41   USE lib_mpp         ! distributed memory computing
42#if defined key_iomput
43   USE mod_ioclient
44#endif
45   USE prtctl          ! Print control                    (prt_ctl_init routine)
46   USE timing          ! Timing
47
48   IMPLICIT NONE
49   PRIVATE
50   
51   PUBLIC   nemo_gcm   ! called by nemo.F90
52
53   CHARACTER (len=64) ::   cform_aaa="( /, 'AAAAAAAA', / ) "   ! flag for output listing
54
55   !!----------------------------------------------------------------------
56   !! NEMO/OFF 3.3 , NEMO Consortium (2010)
57   !! $Id: nemogcm.F90 2528 2010-12-27 17:33:53Z rblod $
58   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
59   !!----------------------------------------------------------------------
60CONTAINS
61
62   SUBROUTINE nemo_gcm
63      !!----------------------------------------------------------------------
64      !!                     ***  ROUTINE nemo_gcm  ***
65      !!
66      !! ** Purpose :   nemo solves the primitive equations on an orthogonal
67      !!      curvilinear mesh on the sphere.
68      !!
69      !! ** Method  : - model general initialization
70      !!              - launch the time-stepping (dta_dyn and trc_stp)
71      !!              - finalize the run by closing files and communications
72      !!
73      !! References : Madec, Delecluse,Imbard, and Levy, 1997:  internal report, IPSL.
74      !!              Madec, 2008, internal report, IPSL.
75      !!----------------------------------------------------------------------
76      INTEGER :: istp, indic       ! time step index
77      !!----------------------------------------------------------------------
78
79      CALL nemo_init  ! Initializations
80
81      IF( lk_mpp )   CALL mpp_max( nstop )
82
83      ! check that all process are still there... If some process have an error,
84      ! they will never enter in step and other processes will wait until the end of the cpu time!
85      IF( lk_mpp )   CALL mpp_max( nstop )
86
87      !                            !-----------------------!
88      !                            !==   time stepping   ==!
89      !                            !-----------------------!
90      istp = nit000
91         !
92      DO WHILE ( istp <= nitend .AND. nstop == 0 )    ! time stepping
93         !
94         IF( istp /= nit000 )   CALL day      ( istp )         ! Calendar (day was already called at nit000 in day_init)
95                                CALL iom_setkt( istp )         ! say to iom that we are at time step kstp
96                                CALL dta_dyn  ( istp )         ! Interpolation of the dynamical fields
97                                CALL trc_stp  ( istp )         ! time-stepping
98                                CALL stp_ctl  ( istp, indic )  ! Time loop: control and print
99         istp = istp + 1
100         IF( lk_mpp )   CALL mpp_max( nstop )
101      END DO
102
103      !                            !------------------------!
104      !                            !==  finalize the run  ==!
105      !                            !------------------------!
106      IF(lwp) WRITE(numout,cform_aaa)                 ! Flag AAAAAAA
107
108      IF( nstop /= 0 .AND. lwp ) THEN                 ! error print
109         WRITE(numout,cform_err)
110         WRITE(numout,*) nstop, ' error have been found'
111      ENDIF
112      !
113      IF( nn_timing == 1 )   CALL timing_finalize
114      !
115      CALL nemo_closefile
116      !
117      IF( lk_mpp )   CALL mppstop                          ! Close all files (mpp)
118      !
119   END SUBROUTINE nemo_gcm
120
121
122   SUBROUTINE nemo_init
123      !!----------------------------------------------------------------------
124      !!                     ***  ROUTINE nemo_init ***
125      !!
126      !! ** Purpose :   initialization of the nemo model in off-line mode
127      !!----------------------------------------------------------------------
128      INTEGER ::   ji            ! dummy loop indices
129      INTEGER ::   ilocal_comm   ! local integer
130      CHARACTER(len=80), DIMENSION(16) ::   cltxt = ''
131      !!
132      NAMELIST/namctl/ ln_ctl  , nn_print, nn_ictls, nn_ictle,   &
133         &             nn_isplt, nn_jsplt, nn_jctls, nn_jctle,   &
134         &             nn_bench, nn_timing
135      !!----------------------------------------------------------------------
136      !
137      !                             ! open Namelist file     
138      CALL ctl_opn( numnam, 'namelist', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
139      !
140      READ( numnam, namctl )        ! Namelist namctl : Control prints & Benchmark
141      !
142      !                             !--------------------------------------------!
143      !                             !  set communicator & select the local node  !
144      !                             !--------------------------------------------!
145#if defined key_iomput
146      CALL  init_ioclient( ilocal_comm )                 ! exchange io_server nemo local communicator with the io_server
147      narea = mynode( cltxt, numnam, nstop, ilocal_comm )   ! Nodes selection
148#else
149      ilocal_comm = 0
150      narea = mynode( cltxt, numnam, nstop )                 ! Nodes selection (control print return in cltxt)
151#endif
152
153      narea = narea + 1                       ! mynode return the rank of proc (0 --> jpnij -1 )
154
155      lwp = (narea == 1) .OR. ln_ctl          ! control of all listing output print
156
157      ! If dimensions of processor grid weren't specified in the namelist file
158      ! then we calculate them here now that we have our communicator size
159      IF( (jpni < 1) .OR. (jpnj < 1) )THEN
160#if   defined key_mpp_mpi   ||   defined key_mpp_shmem
161         CALL nemo_partition(mppsize)
162#else
163         jpni = 1
164         jpnj = 1
165         jpnij = jpni*jpnj
166#endif
167      END IF
168
169      ! Calculate domain dimensions given calculated jpni and jpnj
170      ! This used to be done in par_oce.F90 when they were parameters rather
171      ! than variables
172      jpi = ( jpiglo-2*jpreci + (jpni-1) ) / jpni + 2*jpreci   ! first  dim.
173      jpj = ( jpjglo-2*jprecj + (jpnj-1) ) / jpnj + 2*jprecj   ! second dim.
174      jpk = jpkdta                                             ! third dim
175      jpim1 = jpi-1                                            ! inner domain indices
176      jpjm1 = jpj-1                                            !   "           "
177      jpkm1 = jpk-1                                            !   "           "
178      jpij  = jpi*jpj                                          !  jpi x j
179
180
181      IF(lwp) THEN                            ! open listing units
182         !
183         CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea )
184         !
185         WRITE(numout,*)
186         WRITE(numout,*) '   CNRS - NERC - Met OFFICE - MERCATOR-ocean - INGV - CMCC'
187         WRITE(numout,*) '                       NEMO team'
188         WRITE(numout,*) '            Ocean General Circulation Model'
189         WRITE(numout,*) '                  version 3.5  (2012) '
190         WRITE(numout,*)
191         WRITE(numout,*)
192         DO ji = 1, SIZE(cltxt) 
193            IF( TRIM(cltxt(ji)) /= '' )   WRITE(numout,*) cltxt(ji)      ! control print of mynode
194         END DO
195         WRITE(numout,cform_aaa)                                         ! Flag AAAAAAA
196         !
197      ENDIF
198
199      ! Now we know the dimensions of the grid and numout has been set we can
200      ! allocate arrays
201      CALL nemo_alloc()
202
203      !                             !--------------------------------!
204      !                             !  Model general initialization  !
205      !                             !--------------------------------!
206
207      CALL nemo_ctl                           ! Control prints & Benchmark
208
209      !                                      ! Domain decomposition
210      IF( jpni*jpnj == jpnij ) THEN   ;   CALL mpp_init      ! standard cutting out
211      ELSE                            ;   CALL mpp_init2     ! eliminate land processors
212      ENDIF
213      !
214      IF( nn_timing == 1 )  CALL timing_init
215      !
216
217      !                                      ! General initialization
218      IF( nn_timing == 1 )  CALL timing_start( 'nemo_init')
219      !
220                            CALL     phy_cst    ! Physical constants
221                            CALL     eos_init   ! Equation of state
222                            CALL     dom_cfg    ! Domain configuration
223                            CALL     dom_init   ! Domain
224                            CALL  istate_init   ! ocean initial state (Dynamics and tracers)
225
226      IF( ln_nnogather )    CALL nemo_northcomms   ! Initialise the northfold neighbour lists (must be done after the masks are defined)
227
228      IF( ln_ctl        )   CALL prt_ctl_init   ! Print control
229
230      !                                     ! Ocean physics
231                            CALL     sbc_init   ! Forcings : surface module
232#if ! defined key_degrad
233                            CALL ldf_tra_init   ! Lateral ocean tracer physics
234#endif
235      IF( lk_ldfslp )       CALL ldf_slp_init   ! slope of lateral mixing
236
237      !                                     ! Active tracers
238                            CALL tra_qsr_init   ! penetrative solar radiation qsr
239      IF( lk_trabbl     )   CALL tra_bbl_init   ! advective (and/or diffusive) bottom boundary layer scheme
240
241      !                                     ! Passive tracers
242                            CALL     trc_init   ! Passive tracers initialization
243      !                                     ! Dynamics
244                            CALL dta_dyn_init   ! Initialization for the dynamics
245                            CALL     iom_init       ! iom_put initialization
246
247      IF(lwp) WRITE(numout,cform_aaa)       ! Flag AAAAAAA
248      !
249      IF( nn_timing == 1 )  CALL timing_stop( 'nemo_init')
250      !
251   END SUBROUTINE nemo_init
252
253
254   SUBROUTINE nemo_ctl
255      !!----------------------------------------------------------------------
256      !!                     ***  ROUTINE nemo_ctl  ***
257      !!
258      !! ** Purpose :   control print setting
259      !!
260      !! ** Method  : - print namctl information and check some consistencies
261      !!----------------------------------------------------------------------
262      !
263      IF(lwp) THEN                  ! Parameter print
264         WRITE(numout,*)
265         WRITE(numout,*) 'nemo_flg: Control prints & Benchmark'
266         WRITE(numout,*) '~~~~~~~ '
267         WRITE(numout,*) '   Namelist namctl'
268         WRITE(numout,*) '      run control (for debugging)     ln_ctl     = ', ln_ctl
269         WRITE(numout,*) '      level of print                  nn_print   = ', nn_print
270         WRITE(numout,*) '      Start i indice for SUM control  nn_ictls   = ', nn_ictls
271         WRITE(numout,*) '      End i indice for SUM control    nn_ictle   = ', nn_ictle
272         WRITE(numout,*) '      Start j indice for SUM control  nn_jctls   = ', nn_jctls
273         WRITE(numout,*) '      End j indice for SUM control    nn_jctle   = ', nn_jctle
274         WRITE(numout,*) '      number of proc. following i     nn_isplt   = ', nn_isplt
275         WRITE(numout,*) '      number of proc. following j     nn_jsplt   = ', nn_jsplt
276         WRITE(numout,*) '      benchmark parameter (0/1)       nn_bench   = ', nn_bench
277      ENDIF
278      !
279      nprint    = nn_print          ! convert DOCTOR namelist names into OLD names
280      nictls    = nn_ictls
281      nictle    = nn_ictle
282      njctls    = nn_jctls
283      njctle    = nn_jctle
284      isplt     = nn_isplt
285      jsplt     = nn_jsplt
286      nbench    = nn_bench
287      !                             ! Parameter control
288      !
289      IF( ln_ctl ) THEN                 ! sub-domain area indices for the control prints
290         IF( lk_mpp ) THEN
291            isplt = jpni   ;   jsplt = jpnj   ;   ijsplt = jpni*jpnj   ! the domain is forced to the real splitted domain
292         ELSE
293            IF( isplt == 1 .AND. jsplt == 1  ) THEN
294               CALL ctl_warn( ' - isplt & jsplt are equal to 1',   &
295                  &           ' - the print control will be done over the whole domain' )
296            ENDIF
297            ijsplt = isplt * jsplt            ! total number of processors ijsplt
298         ENDIF
299         IF(lwp) WRITE(numout,*)'          - The total number of processors over which the'
300         IF(lwp) WRITE(numout,*)'            print control will be done is ijsplt : ', ijsplt
301         !
302         !                              ! indices used for the SUM control
303         IF( nictls+nictle+njctls+njctle == 0 )   THEN    ! print control done over the default area
304            lsp_area = .FALSE.
305         ELSE                                             ! print control done over a specific  area
306            lsp_area = .TRUE.
307            IF( nictls < 1 .OR. nictls > jpiglo )   THEN
308               CALL ctl_warn( '          - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )
309               nictls = 1
310            ENDIF
311            IF( nictle < 1 .OR. nictle > jpiglo )   THEN
312               CALL ctl_warn( '          - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )
313               nictle = jpiglo
314            ENDIF
315            IF( njctls < 1 .OR. njctls > jpjglo )   THEN
316               CALL ctl_warn( '          - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )
317               njctls = 1
318            ENDIF
319            IF( njctle < 1 .OR. njctle > jpjglo )   THEN
320               CALL ctl_warn( '          - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )
321               njctle = jpjglo
322            ENDIF
323         ENDIF
324      ENDIF
325      !
326      IF( nbench == 1 )   THEN            ! Benchmark
327         SELECT CASE ( cp_cfg )
328         CASE ( 'gyre' )   ;   CALL ctl_warn( ' The Benchmark is activated ' )
329         CASE DEFAULT      ;   CALL ctl_stop( ' The Benchmark is based on the GYRE configuration:',   &
330            &                                 ' key_gyre must be used or set nbench = 0' )
331         END SELECT
332      ENDIF
333      !
334      IF( lk_c1d .AND. .NOT.lk_iomput )   CALL ctl_stop( 'nemo_ctl: The 1D configuration must be used ',   &
335         &                                               'with the IOM Input/Output manager. '        ,   &
336         &                                               'Compile with key_iomput enabled' )
337      !
338   END SUBROUTINE nemo_ctl
339
340
341   SUBROUTINE nemo_closefile
342      !!----------------------------------------------------------------------
343      !!                     ***  ROUTINE nemo_closefile  ***
344      !!
345      !! ** Purpose :   Close the files
346      !!----------------------------------------------------------------------
347      !
348      IF ( lk_mpp ) CALL mppsync
349      !
350      CALL iom_close                                 ! close all input/output files managed by iom_*
351      !
352      IF( numstp     /= -1 )   CLOSE( numstp     )   ! time-step file
353      IF( numnam     /= -1 )   CLOSE( numnam     )   ! oce namelist
354      IF( numout     /=  6 )   CLOSE( numout     )   ! standard model output file
355      numout = 6                                     ! redefine numout in case it is used after this point...
356      !
357   END SUBROUTINE nemo_closefile
358
359
360   SUBROUTINE nemo_alloc
361      !!----------------------------------------------------------------------
362      !!                     ***  ROUTINE nemo_alloc  ***
363      !!
364      !! ** Purpose :   Allocate all the dynamic arrays of the OPA modules
365      !!
366      !! ** Method  :
367      !!----------------------------------------------------------------------
368      USE diawri,       ONLY: dia_wri_alloc
369      USE dom_oce,      ONLY: dom_oce_alloc
370      USE zdf_oce,      ONLY: zdf_oce_alloc
371      USE ldftra_oce,   ONLY: ldftra_oce_alloc
372      USE trc_oce,      ONLY: trc_oce_alloc
373      !
374      INTEGER :: ierr
375      !!----------------------------------------------------------------------
376      !
377      ierr =        oce_alloc       ()          ! ocean
378      ierr = ierr + dia_wri_alloc   ()
379      ierr = ierr + dom_oce_alloc   ()          ! ocean domain
380      ierr = ierr + ldftra_oce_alloc()          ! ocean lateral  physics : tracers
381      ierr = ierr + zdf_oce_alloc   ()          ! ocean vertical physics
382      !
383      ierr = ierr + lib_mpp_alloc   (numout)    ! mpp exchanges
384      ierr = ierr + trc_oce_alloc   ()          ! shared TRC / TRA arrays
385      !
386      IF( lk_mpp    )   CALL mpp_sum( ierr )
387      IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'nemo_alloc: unable to allocate standard ocean arrays' )
388      !
389   END SUBROUTINE nemo_alloc
390
391
392   SUBROUTINE nemo_partition( num_pes )
393      !!----------------------------------------------------------------------
394      !!                 ***  ROUTINE nemo_partition  ***
395      !!
396      !! ** Purpose :   
397      !!
398      !! ** Method  :
399      !!----------------------------------------------------------------------
400      INTEGER, INTENT(in) :: num_pes ! The number of MPI processes we have
401      !
402      INTEGER, PARAMETER :: nfactmax = 20
403      INTEGER :: nfact ! The no. of factors returned
404      INTEGER :: ierr  ! Error flag
405      INTEGER :: ji
406      INTEGER :: idiff, mindiff, imin ! For choosing pair of factors that are closest in value
407      INTEGER, DIMENSION(nfactmax) :: ifact ! Array of factors
408      !!----------------------------------------------------------------------
409
410      ierr = 0
411
412      CALL factorise( ifact, nfactmax, nfact, num_pes, ierr )
413
414      IF( nfact <= 1 ) THEN
415         WRITE (numout, *) 'WARNING: factorisation of number of PEs failed'
416         WRITE (numout, *) '       : using grid of ',num_pes,' x 1'
417         jpnj = 1
418         jpni = num_pes
419      ELSE
420         ! Search through factors for the pair that are closest in value
421         mindiff = 1000000
422         imin    = 1
423         DO ji = 1, nfact-1, 2
424            idiff = ABS( ifact(ji) - ifact(ji+1) )
425            IF( idiff < mindiff ) THEN
426               mindiff = idiff
427               imin = ji
428            ENDIF
429         END DO
430         jpnj = ifact(imin)
431         jpni = ifact(imin + 1)
432      ENDIF
433      !
434      jpnij = jpni*jpnj
435      !
436   END SUBROUTINE nemo_partition
437
438
439   SUBROUTINE factorise( kfax, kmaxfax, knfax, kn, kerr )
440      !!----------------------------------------------------------------------
441      !!                     ***  ROUTINE factorise  ***
442      !!
443      !! ** Purpose :   return the prime factors of n.
444      !!                knfax factors are returned in array kfax which is of
445      !!                maximum dimension kmaxfax.
446      !! ** Method  :
447      !!----------------------------------------------------------------------
448      INTEGER                    , INTENT(in   ) ::   kn, kmaxfax
449      INTEGER                    , INTENT(  out) ::   kerr, knfax
450      INTEGER, DIMENSION(kmaxfax), INTENT(  out) ::   kfax
451      !
452      INTEGER :: ifac, jl, inu
453      INTEGER, PARAMETER :: ntest = 14
454      INTEGER :: ilfax(ntest)
455      !
456      ! lfax contains the set of allowed factors.
457      data (ilfax(jl),jl=1,ntest) / 16384, 8192, 4096, 2048, 1024, 512, 256,  &
458         &                            128,   64,   32,   16,    8,   4,   2  /
459      !!----------------------------------------------------------------------
460
461      ! Clear the error flag and initialise output vars
462      kerr = 0
463      kfax = 1
464      knfax = 0
465
466      ! Find the factors of n.
467      IF( kn == 1 )   GOTO 20
468
469      ! nu holds the unfactorised part of the number.
470      ! knfax holds the number of factors found.
471      ! l points to the allowed factor list.
472      ! ifac holds the current factor.
473
474      inu   = kn
475      knfax = 0
476
477      DO jl = ntest, 1, -1
478         !
479         ifac = ilfax(jl)
480         IF( ifac > inu )   CYCLE
481
482         ! Test whether the factor will divide.
483
484         IF( MOD(inu,ifac) == 0 ) THEN
485            !
486            knfax = knfax + 1            ! Add the factor to the list
487            IF( knfax > kmaxfax ) THEN
488               kerr = 6
489               write (*,*) 'FACTOR: insufficient space in factor array ', knfax
490               return
491            ENDIF
492            kfax(knfax) = ifac
493            ! Store the other factor that goes with this one
494            knfax = knfax + 1
495            kfax(knfax) = inu / ifac
496            !WRITE (*,*) 'ARPDBG, factors ',knfax-1,' & ',knfax,' are ', kfax(knfax-1),' and ',kfax(knfax)
497         ENDIF
498         !
499      END DO
500
501   20 CONTINUE      ! Label 20 is the exit point from the factor search loop.
502      !
503   END SUBROUTINE factorise
504
505#if defined key_mpp_mpi
506   SUBROUTINE nemo_northcomms
507      !!======================================================================
508      !!                     ***  ROUTINE  nemo_northcomms  ***
509      !! nemo_northcomms    :  Setup for north fold exchanges with explicit peer to peer messaging
510      !!=====================================================================
511      !!----------------------------------------------------------------------
512      !!
513      !! ** Purpose :   Initialization of the northern neighbours lists.
514      !!----------------------------------------------------------------------
515      !!    1.0  ! 2011-10  (A. C. Coward, NOCS & J. Donners, PRACE)
516      !!----------------------------------------------------------------------
517
518      INTEGER ::   ji, jj, jk, ij, jtyp    ! dummy loop indices
519      INTEGER ::   ijpj                    ! number of rows involved in north-fold exchange
520      INTEGER ::   northcomms_alloc        ! allocate return status
521      REAL(wp), ALLOCATABLE, DIMENSION ( :,: ) ::   znnbrs     ! workspace
522      LOGICAL,  ALLOCATABLE, DIMENSION ( : )   ::   lrankset   ! workspace
523
524      IF(lwp) WRITE(numout,*)
525      IF(lwp) WRITE(numout,*) 'nemo_northcomms : Initialization of the northern neighbours lists'
526      IF(lwp) WRITE(numout,*) '~~~~~~~~~~'
527
528      !!----------------------------------------------------------------------
529      ALLOCATE( znnbrs(jpi,jpj), stat = northcomms_alloc )
530      ALLOCATE( lrankset(jpnij), stat = northcomms_alloc )
531      IF( northcomms_alloc /= 0 ) THEN
532         WRITE(numout,cform_war)
533         WRITE(numout,*) 'northcomms_alloc : failed to allocate arrays'
534         CALL ctl_stop( 'STOP', 'nemo_northcomms : unable to allocate temporary arrays' )
535      ENDIF
536      nsndto = 0
537      isendto = -1
538      ijpj   = 4
539      !
540      ! This routine has been called because ln_nnogather has been set true ( nammpp )
541      ! However, these first few exchanges have to use the mpi_allgather method to
542      ! establish the neighbour lists to use in subsequent peer to peer exchanges.
543      ! Consequently, set l_north_nogather to be false here and set it true only after
544      ! the lists have been established.
545      !
546      l_north_nogather = .FALSE.
547      !
548      ! Exchange and store ranks on northern rows
549
550      DO jtyp = 1,4
551
552         lrankset = .FALSE.
553         znnbrs = narea
554         SELECT CASE (jtyp)
555            CASE(1)
556               CALL lbc_lnk( znnbrs, 'T', 1. )      ! Type 1: T,W-points
557            CASE(2)
558               CALL lbc_lnk( znnbrs, 'U', 1. )      ! Type 2: U-point
559            CASE(3)
560               CALL lbc_lnk( znnbrs, 'V', 1. )      ! Type 3: V-point
561            CASE(4)
562               CALL lbc_lnk( znnbrs, 'F', 1. )      ! Type 4: F-point
563         END SELECT
564
565         IF ( njmppt(narea) .EQ. MAXVAL( njmppt ) ) THEN
566            DO jj = nlcj-ijpj+1, nlcj
567               ij = jj - nlcj + ijpj
568               DO ji = 1,jpi
569                  IF ( INT(znnbrs(ji,jj)) .NE. 0 .AND. INT(znnbrs(ji,jj)) .NE. narea ) &
570               &     lrankset(INT(znnbrs(ji,jj))) = .true.
571               END DO
572            END DO
573
574            DO jj = 1,jpnij
575               IF ( lrankset(jj) ) THEN
576                  nsndto(jtyp) = nsndto(jtyp) + 1
577                  IF ( nsndto(jtyp) .GT. jpmaxngh ) THEN
578                     CALL ctl_stop( ' Too many neighbours in nemo_northcomms ', &
579                  &                 ' jpmaxngh will need to be increased ')
580                  ENDIF
581                  isendto(nsndto(jtyp),jtyp) = jj-1   ! narea converted to MPI rank
582               ENDIF
583            END DO
584         ENDIF
585
586      END DO
587
588      !
589      ! Type 5: I-point
590      !
591      ! ICE point exchanges may involve some averaging. The neighbours list is
592      ! built up using two exchanges to ensure that the whole stencil is covered.
593      ! lrankset should not be reset between these 'J' and 'K' point exchanges
594
595      jtyp = 5
596      lrankset = .FALSE.
597      znnbrs = narea 
598      CALL lbc_lnk( znnbrs, 'J', 1. ) ! first ice U-V point
599
600      IF ( njmppt(narea) .EQ. MAXVAL( njmppt ) ) THEN
601         DO jj = nlcj-ijpj+1, nlcj
602            ij = jj - nlcj + ijpj
603            DO ji = 1,jpi
604               IF ( INT(znnbrs(ji,jj)) .NE. 0 .AND. INT(znnbrs(ji,jj)) .NE. narea ) &
605            &     lrankset(INT(znnbrs(ji,jj))) = .true.
606         END DO
607        END DO
608      ENDIF
609
610      znnbrs = narea 
611      CALL lbc_lnk( znnbrs, 'K', 1. ) ! second ice U-V point
612
613      IF ( njmppt(narea) .EQ. MAXVAL( njmppt )) THEN
614         DO jj = nlcj-ijpj+1, nlcj
615            ij = jj - nlcj + ijpj
616            DO ji = 1,jpi
617               IF ( INT(znnbrs(ji,jj)) .NE. 0 .AND.  INT(znnbrs(ji,jj)) .NE. narea ) &
618            &       lrankset( INT(znnbrs(ji,jj))) = .true.
619            END DO
620         END DO
621
622         DO jj = 1,jpnij
623            IF ( lrankset(jj) ) THEN
624               nsndto(jtyp) = nsndto(jtyp) + 1
625               IF ( nsndto(jtyp) .GT. jpmaxngh ) THEN
626                  CALL ctl_stop( ' Too many neighbours in nemo_northcomms ', &
627               &                 ' jpmaxngh will need to be increased ')
628               ENDIF
629               isendto(nsndto(jtyp),jtyp) = jj-1   ! narea converted to MPI rank
630            ENDIF
631         END DO
632         !
633         ! For northern row areas, set l_north_nogather so that all subsequent exchanges
634         ! can use peer to peer communications at the north fold
635         !
636         l_north_nogather = .TRUE.
637         !
638      ENDIF
639      DEALLOCATE( znnbrs )
640      DEALLOCATE( lrankset )
641
642   END SUBROUTINE nemo_northcomms
643#else
644   SUBROUTINE nemo_northcomms      ! Dummy routine
645      WRITE(*,*) 'nemo_northcomms: You should not have seen this print! error?'
646   END SUBROUTINE nemo_northcomms
647#endif
648   !!======================================================================
649END MODULE nemogcm
Note: See TracBrowser for help on using the repository browser.