source: vendor/nemo/v3.4_r_3220_dev_NEMO_MERGE_2011/NEMOGCM/NEMO/OFF_SRC/nemogcm.F90 @ 86

Last change on this file since 86 was 1, checked in by cholod, 13 years ago

importing initial nemo vendor drop (v3.4_r_3220)
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'
187         WRITE(numout,*) '                       NEMO team'
188         WRITE(numout,*) '            Ocean General Circulation Model'
189         WRITE(numout,*) '                  version 3.3  (2010) '
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.