Changeset 2715 for trunk/NEMOGCM/NEMO/OFF_SRC/nemogcm.F90

Timestamp:

2011-03-30T17:58:35+02:00 (13 years ago)

Author:

rblod

Message:

First attempt to put dynamic allocation on the trunk

File:

• trunk/NEMOGCM/NEMO/OFF_SRC/nemogcm.F90 (modified) (8 diffs)

trunk/NEMOGCM/NEMO/OFF_SRC/nemogcm.F90

@@ -5 +5 @@
    !!======================================================================
    !! History :  3.3  ! 2010-05  (C. Ethe)  Full reorganization of the off-line: phasing with the on-line
+   !!            4.0  ! 2011-01  (C. Ethe, A. R. Porter, STFC Daresbury) dynamical allocation
    !!----------------------------------------------------------------------
 
@@ -26 +27 @@
    USE trabbl          ! bottom boundary layer          (tra_bbl_init routine)
    USE zdfini          ! vertical physics: initialization
+   USE sbcmod          ! surface boundary condition       (sbc_init     routine)
    USE phycst          ! physical constant                  (par_cst routine)
    USE dtadyn          ! Lecture and Interpolation of the dynamical fields
@@ -39 +41 @@
    USE lib_mpp         ! distributed memory computing
 #if defined key_iomput
-   USE  mod_ioclient
+   USE mod_ioclient
 #endif 
+   USE prtctl           ! Print control                    (prt_ctl_init routine)
 
    IMPLICIT NONE
@@ -122 +125 @@
       INTEGER ::   ji            ! dummy loop indices
       INTEGER ::   ilocal_comm   ! local integer
-      CHARACTER(len=80), DIMENSION(10) ::   cltxt = ''
+      CHARACTER(len=80), DIMENSION(16) ::   cltxt = ''
       !!
       NAMELIST/namctl/ ln_ctl  , nn_print, nn_ictls, nn_ictle,   &
@@ -137 +140 @@
       !                             !--------------------------------------------!
 #if defined key_iomput
-      CALL init_ioclient( ilocal_comm )       ! nemo local communicator (used or not) given by the io_server
-      narea = mynode( cltxt, ilocal_comm )    ! Nodes selection
+      CALL  init_ioclient( ilocal_comm )                 ! exchange io_server nemo local communicator with the io_server
+      narea = mynode( cltxt, numnam, nstop, ilocal_comm )   ! Nodes selection
 #else
-      narea = mynode( cltxt )                 ! Nodes selection (control print return in cltxt)
+      ilocal_comm = 0
+      narea = mynode( cltxt, numnam, nstop )                 ! Nodes selection (control print return in cltxt)
 #endif
+
       narea = narea + 1                       ! mynode return the rank of proc (0 --> jpnij -1 )
 
       lwp = (narea == 1) .OR. ln_ctl          ! control of all listing output print
+
+      ! If dimensions of processor grid weren't specified in the namelist file 
+      ! then we calculate them here now that we have our communicator size
+      IF( (jpni < 1) .OR. (jpnj < 1) )THEN
+#if   defined key_mpp_mpi   ||   defined key_mpp_shmem
+         CALL nemo_partition(mppsize)
+#else
+         jpni = 1
+         jpnj = 1
+         jpnij = jpni*jpnj
+#endif
+      END IF
+
+      ! Calculate domain dimensions given calculated jpni and jpnj
+      ! This used to be done in par_oce.F90 when they were parameters rather
+      ! than variables
+      jpi = ( jpiglo-2*jpreci + (jpni-1) ) / jpni + 2*jpreci   ! first  dim.
+      jpj = ( jpjglo-2*jprecj + (jpnj-1) ) / jpnj + 2*jprecj   ! second dim.
+      jpk = jpkdta                                             ! third dim
+      jpim1 = jpi-1                                            ! inner domain indices
+      jpjm1 = jpj-1                                            !   "           "
+      jpkm1 = jpk-1                                            !   "           "
+      jpij  = jpi*jpj                                          !  jpi x j
+
 
       IF(lwp) THEN                            ! open listing units
@@ -163 +192 @@
          !
       ENDIF
+
+      ! Now we know the dimensions of the grid and numout has been set we can 
+      ! allocate arrays
+      CALL nemo_alloc()
+
       !                             !--------------------------------!
       !                             !  Model general initialization  !
@@ -181 +215 @@
                             CALL  istate_init   ! ocean initial state (Dynamics and tracers)
 
+
+      IF( ln_ctl        )   CALL prt_ctl_init   ! Print control
+
       !                                     ! Ocean physics
+                            CALL     sbc_init   ! Forcings : surface module
 #if ! defined key_degrad
                             CALL ldf_tra_init   ! Lateral ocean tracer physics
@@ -307 +345 @@
    END SUBROUTINE nemo_closefile
 
+
+   SUBROUTINE nemo_alloc
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE nemo_alloc  ***
+      !!
+      !! ** Purpose :   Allocate all the dynamic arrays of the OPA modules
+      !!
+      !! ** Method  :
+      !!----------------------------------------------------------------------
+      USE diawri,       ONLY: dia_wri_alloc
+      USE dom_oce,      ONLY: dom_oce_alloc
+      USE zdf_oce,      ONLY: zdf_oce_alloc
+      USE zdfmxl,       ONLY: zdf_mxl_alloc
+      USE ldftra_oce,   ONLY: ldftra_oce_alloc
+      USE trc_oce,      ONLY: trc_oce_alloc
+      USE wrk_nemo,    ONLY: wrk_alloc
+      !
+      INTEGER :: ierr
+      !!----------------------------------------------------------------------
+      !
+      ierr =        oce_alloc       ()          ! ocean 
+      ierr = ierr + dia_wri_alloc   ()
+      ierr = ierr + dom_oce_alloc   ()          ! ocean domain
+      ierr = ierr + ldftra_oce_alloc()          ! ocean lateral  physics : tracers
+      ierr = ierr + zdf_oce_alloc   ()          ! ocean vertical physics
+      ierr = ierr + zdf_mxl_alloc   ()          ! ocean vertical physics
+      !
+      ierr = ierr + lib_mpp_alloc   (numout)    ! mpp exchanges
+      ierr = ierr + trc_oce_alloc   ()          ! shared TRC / TRA arrays
+      ierr = ierr + wrk_alloc(numout, lwp)
+      !
+      IF( lk_mpp    )   CALL mpp_sum( ierr )
+      IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'nemo_alloc: unable to allocate standard ocean arrays' )
+      !
+   END SUBROUTINE nemo_alloc
+
+
+   SUBROUTINE nemo_partition( num_pes )
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE nemo_partition  ***
+      !!
+      !! ** Purpose :   
+      !!
+      !! ** Method  :
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) :: num_pes ! The number of MPI processes we have
+      !
+      INTEGER, PARAMETER :: nfactmax = 20
+      INTEGER :: nfact ! The no. of factors returned
+      INTEGER :: ierr  ! Error flag
+      INTEGER :: ji
+      INTEGER :: idiff, mindiff, imin ! For choosing pair of factors that are closest in value
+      INTEGER, DIMENSION(nfactmax) :: ifact ! Array of factors
+      !!----------------------------------------------------------------------
+
+      ierr = 0
+
+      CALL factorise( ifact, nfactmax, nfact, num_pes, ierr )
+
+      IF( nfact <= 1 ) THEN
+         WRITE (numout, *) 'WARNING: factorisation of number of PEs failed'
+         WRITE (numout, *) '       : using grid of ',num_pes,' x 1'
+         jpnj = 1
+         jpni = num_pes
+      ELSE
+         ! Search through factors for the pair that are closest in value
+         mindiff = 1000000
+         imin    = 1
+         DO ji = 1, nfact-1, 2
+            idiff = ABS( ifact(ji) - ifact(ji+1) )
+            IF( idiff < mindiff ) THEN
+               mindiff = idiff
+               imin = ji
+            ENDIF
+         END DO
+         jpnj = ifact(imin)
+         jpni = ifact(imin + 1)
+      ENDIF
+      !
+      jpnij = jpni*jpnj
+      !
+   END SUBROUTINE nemo_partition
+
+
+   SUBROUTINE factorise( kfax, kmaxfax, knfax, kn, kerr )
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE factorise  ***
+      !!
+      !! ** Purpose :   return the prime factors of n.
+      !!                knfax factors are returned in array kfax which is of 
+      !!                maximum dimension kmaxfax.
+      !! ** Method  :
+      !!----------------------------------------------------------------------
+      INTEGER                    , INTENT(in   ) ::   kn, kmaxfax
+      INTEGER                    , INTENT(  out) ::   kerr, knfax
+      INTEGER, DIMENSION(kmaxfax), INTENT(  out) ::   kfax
+      !
+      INTEGER :: ifac, jl, inu
+      INTEGER, PARAMETER :: ntest = 14
+      INTEGER :: ilfax(ntest)
+      !
+      ! lfax contains the set of allowed factors.
+      data (ilfax(jl),jl=1,ntest) / 16384, 8192, 4096, 2048, 1024, 512, 256,  &
+         &                            128,   64,   32,   16,    8,   4,   2  /
+      !!----------------------------------------------------------------------
+
+      ! Clear the error flag and initialise output vars
+      kerr = 0
+      kfax = 1
+      knfax = 0
+
+      ! Find the factors of n.
+      IF( kn == 1 )   GOTO 20
+
+      ! nu holds the unfactorised part of the number.
+      ! knfax holds the number of factors found.
+      ! l points to the allowed factor list.
+      ! ifac holds the current factor.
+
+      inu   = kn
+      knfax = 0
+
+      DO jl = ntest, 1, -1
+         !
+         ifac = ilfax(jl)
+         IF( ifac > inu )   CYCLE
+
+         ! Test whether the factor will divide.
+
+         IF( MOD(inu,ifac) == 0 ) THEN
+            !
+            knfax = knfax + 1            ! Add the factor to the list
+            IF( knfax > kmaxfax ) THEN
+               kerr = 6
+               write (*,*) 'FACTOR: insufficient space in factor array ', knfax
+               return
+            ENDIF
+            kfax(knfax) = ifac
+            ! Store the other factor that goes with this one
+            knfax = knfax + 1
+            kfax(knfax) = inu / ifac
+            !WRITE (*,*) 'ARPDBG, factors ',knfax-1,' & ',knfax,' are ', kfax(knfax-1),' and ',kfax(knfax)
+         ENDIF
+         !
+      END DO
+
+   20 CONTINUE      ! Label 20 is the exit point from the factor search loop.
+      !
+   END SUBROUTINE factorise
+
    !!======================================================================
 END MODULE nemogcm